Add Loop to code
 

The following code searches throgh a list of of like items until it finds a
different item, then it selects and
groups the like items. How can I add a loop to the code so it will find and
group all of the like items instead
of just the first occurance?

Thanks

Alex



Sub CopyData()

Dim LRow As Integer
Dim LColARange, LColARange0, LColARowUp, Row As String
Dim LContinue As Boolean

'Select Sheet1
Sheets("Sheet1").Select
Range("A2").Select

'Initialize variables
LContinue = True
LRow = 2

'Loop through all column A values until a blank cell is found or value
does not
' match cell A2's value
While LContinue = True

LRow = LRow + 1
LColARange = "A" & CStr(LRow)

'Found a blank cell, do not continue
If Len(Range(LColARange).Value) = 0 Then
LContinue = False
End If

'Found first occurrence that did not match cell A2's value, do not
continue
If Range("A2").Value < Range(LColARange).Value Then
LContinue = False
End If

Wend

LColARange = "A" & CStr(LRow)
LColARange0 = "A" & CStr(LRow - 1) 'Lower Boundary
Row = CStr(LRow) & ":" & CStr(LRow)
lowerrow = CStr(LRow - 1)
upperrow = lowerrow - (lowerrow - 1) + 1
GrpRange = upperrow & ":" & lowerrow

Rows(Row).Select
Selection.Insert Shift:=xlDown
Range(LColARange0).Select
Selection.Copy
Range(LColARange).Select
ActiveSheet.Paste
Range(LColARange).Select
Selection.Font.Bold = True

Rows(GrpRange).Select
Selection.Rows.Group

Add Loop to code
 

Take a look at Find and FindNext in help, it should do what you want.

--

HTH

Bob Phillips

(replace xxxx in the email address with gmail if mailing direct)

"Alex" wrote in message
...
The following code searches throgh a list of of like items until it finds
a
different item, then it selects and
groups the like items. How can I add a loop to the code so it will find
and
group all of the like items instead
of just the first occurance?

Thanks

Alex



Sub CopyData()

Dim LRow As Integer
Dim LColARange, LColARange0, LColARowUp, Row As String
Dim LContinue As Boolean

'Select Sheet1
Sheets("Sheet1").Select
Range("A2").Select

'Initialize variables
LContinue = True
LRow = 2

'Loop through all column A values until a blank cell is found or value
does not
' match cell A2's value
While LContinue = True

LRow = LRow + 1
LColARange = "A" & CStr(LRow)

'Found a blank cell, do not continue
If Len(Range(LColARange).Value) = 0 Then
LContinue = False
End If

'Found first occurrence that did not match cell A2's value, do not
continue
If Range("A2").Value < Range(LColARange).Value Then
LContinue = False
End If

Wend

LColARange = "A" & CStr(LRow)
LColARange0 = "A" & CStr(LRow - 1) 'Lower Boundary
Row = CStr(LRow) & ":" & CStr(LRow)
lowerrow = CStr(LRow - 1)
upperrow = lowerrow - (lowerrow - 1) + 1
GrpRange = upperrow & ":" & lowerrow

Rows(Row).Select
Selection.Insert Shift:=xlDown
Range(LColARange0).Select
Selection.Copy
Range(LColARange).Select
ActiveSheet.Paste
Range(LColARange).Select
Selection.Font.Bold = True

Rows(GrpRange).Select
Selection.Rows.Group