G
Guest
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
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