Loop Help
 

In my macro I read thru column "A" for a specified string of text, then paste
a range of values to another worksheet. However, when it finds duplicate
entries from the first sheet it fails to paste any data onto the other
worksheet?
If the macro finds more than one entry for "sUserPart" how can I get each
data set pasted on the other worksheet in contiguous rows?

If the inital data from sUserPart is not duplicated I do not want to simply
stack the data on to the other worksheet.

'======
Option Explicit
Dim sUserPart As String
Dim sDate As String
Dim Sh1LastRow
Dim Sh1Range
Dim Sh1Cell
Dim sh1x1 As String
Dim sh1x2 As String
Dim sRowData As String

Private Sub CommandButton1_Click()
If UserPart.Value = "" Then 'from textbox1
MsgBox "You must enter a Value in " & """Part Number""" & " text box!"
End If
If IsDate(UserDate.Value) = False Then 'from textbox2
MsgBox "You must enter a valid date in " & """Job Due By""" & " text box in
a Date format (mm/dd/yy)!"
End If
With Sheets("Part Number")
Sh1LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
Set Sh1Range = .Range("A2:A" & Sh1LastRow)
End With
'MsgBox Sh1LastRow 'for testing
For Each Sh1Cell In Sh1Range
If Sh1Cell.Value = sUserPart Then 'search column A for "sUserPart" (textbox1)
sh1x1 = Replace(Sh1Cell.Address, "$", "")
sh1x2 = Replace(sh1x1, "A", "")
sRowData = sh1x1 & ":H" & sh1x2 'set address range
'MsgBox sRowData 'for testing
'if duplicate entry from sheet "Part Number" is found need to add both entries
Sheets("Print Data").Unprotect "2000"
Range(sRowData).Copy Destination:=Sheets("Print Data").Range("A2") 'paste
Sheets("Print Data").Select
Columns("A:H").Select
Selection.Columns.AutoFit
Range("A2").Select
Sheets("Print Data").Protect "2000"
End If
Next Sh1Cell
Unload Me
End Sub
'======
--
Regards

VBA.Noob.Confused
XP Pro
Office 2007

Loop Help
 

I managed to figure this out. I was not returning to the original sheet to
collect data, hence the next row would be blank and that is he data copied.

This code:
'======
Sheets("Part Number").Activate '****New code
End If
Next Sh1Cell
Unload Me
End Sub
'======
Was this code:
'======
End If
Next Sh1Cell
Unload Me
End Sub
'======
Some times it's so simple it's hard to see. I give credit for me being able
to find such an error to this NG!!!
--
Regards

VBA.Noob.Confused
XP Pro
Office 2007



"Rick S." wrote:

In my macro I read thru column "A" for a specified string of text, then paste
a range of values to another worksheet. However, when it finds duplicate
entries from the first sheet it fails to paste any data onto the other
worksheet?
If the macro finds more than one entry for "sUserPart" how can I get each
data set pasted on the other worksheet in contiguous rows?

If the inital data from sUserPart is not duplicated I do not want to simply
stack the data on to the other worksheet.

'======
Option Explicit
Dim sUserPart As String
Dim sDate As String
Dim Sh1LastRow
Dim Sh1Range
Dim Sh1Cell
Dim sh1x1 As String
Dim sh1x2 As String
Dim sRowData As String

Private Sub CommandButton1_Click()
If UserPart.Value = "" Then 'from textbox1
MsgBox "You must enter a Value in " & """Part Number""" & " text box!"
End If
If IsDate(UserDate.Value) = False Then 'from textbox2
MsgBox "You must enter a valid date in " & """Job Due By""" & " text box in
a Date format (mm/dd/yy)!"
End If
With Sheets("Part Number")
Sh1LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
Set Sh1Range = .Range("A2:A" & Sh1LastRow)
End With
'MsgBox Sh1LastRow 'for testing
For Each Sh1Cell In Sh1Range
If Sh1Cell.Value = sUserPart Then 'search column A for "sUserPart" (textbox1)
sh1x1 = Replace(Sh1Cell.Address, "$", "")
sh1x2 = Replace(sh1x1, "A", "")
sRowData = sh1x1 & ":H" & sh1x2 'set address range
'MsgBox sRowData 'for testing
'if duplicate entry from sheet "Part Number" is found need to add both entries
Sheets("Print Data").Unprotect "2000"
Range(sRowData).Copy Destination:=Sheets("Print Data").Range("A2") 'paste
Sheets("Print Data").Select
Columns("A:H").Select
Selection.Columns.AutoFit
Range("A2").Select
Sheets("Print Data").Protect "2000"
End If
Next Sh1Cell
Unload Me
End Sub
'======
--
Regards

VBA.Noob.Confused
XP Pro
Office 2007