Hi All,
I am currently trying to write a macro which will group columns in a specified range on the basis of a criteria for e.g. I have a range from Columns A to D then my macro will be looking into the 4th row of each column and see if there is a zero value or blank in the same if for e.g. If A4 has zero value and B4 also has zero value then it will group A4 and B4 columns together or if only A4 has value zero then it will hide A column and this way it will loop through the entire column range specified and do the grouping. Following is the code which I have currently with me.
Thanks a lot for your help in advance.
I am currently trying to write a macro which will group columns in a specified range on the basis of a criteria for e.g. I have a range from Columns A to D then my macro will be looking into the 4th row of each column and see if there is a zero value or blank in the same if for e.g. If A4 has zero value and B4 also has zero value then it will group A4 and B4 columns together or if only A4 has value zero then it will hide A column and this way it will loop through the entire column range specified and do the grouping. Following is the code which I have currently with me.
Code:
Sub AutoGroup()
Application. ScreenUpdating = False
Dim intFirstColumn As Integer
Dim intLastColumn As Integer
intFirstColumn = 0
'Format rows and columns
Columns("B:Z").Select
'Set AutoFilter
Range("B4").Select
Do Until ActiveCell.Value <> 0
If ActiveCell.Value = ActiveCell.Offset(0, 1).Value Then
'First Match
If intFirstColumn = 0 Then intFirstColumn = ActiveCell.Row + 1
'If not the first match, do nothing. Continue on.
Else
'If intFirstColumn is not 0, and the next cell does not match,
'we've reached the end of the group. Create the group.
If intFirstColumn <> 0 Then
intLastColumn = ActiveCell.Row
Columns(intFirstColumn & ":" & intLastColumn).Select
Selection.Columns.Group
intFirstColumn = 0
Range("A" & intLastColumn).Select
End If
'If intFirstColumn = 0, and the next cell does not match, this
'cell is unmatched, and there is no group. Continue on.
End If
ActiveCell.Offset(0, 1).Select
Loop
Application.ScreenUpdating = True
End Sub
Last edited by a moderator:
