VBA to Group Rows Based on Same Values

austinandreikurt

Board Regular
Joined
Aug 25, 2020
Messages
80
Office Version
  1. 2016
Platform
  1. Windows
Hi,
I think this is easy but I just can't figure out the logic I need to group rows based on rows in a column with same values. Technically, its like grouping main group and subgroup based on their values. I created a formula-based column that indicate numbers based on cell values e.g Group all 1, group all 2 and so on. My values are simplified through integers and it will always be in ascending order like if Cell A1 to A5 is 1 and Cell A6 to A15 is 2, it is impossible to have another 1 in other cells in Column A. Below are the conditions:
1. Direction of Grouping is to Summarize Rows Above Detail
2. The first instance of the number will be the Main Group and the rest are subgroups
3. Grouping will only happen if the values have 2 or more. You will see in the minisheet the #7 in Cell A43 not grouped since there is no similar values
4. Grouping should only for cells with numbers, meaning 0 and blanks should not be grouped.
Thank you in advance!

Book1
A
1
2
3
4
5
6
70
80
90
100
111
122
132
142
153
163
173
183
193
203
213
223
233
243
254
264
274
284
295
305
315
325
335
345
355
365
375
386
396
406
416
426
437
448
458
468
478
488
498
508
518
528
538
549
559
569
579
589
599
609
619
629
639
649
Sheet1
 

Attachments

  • Screenshot 2022-07-13 155138.png
    Screenshot 2022-07-13 155138.png
    11.2 KB · Views: 8
  • Screenshot 2022-07-13 155349.png
    Screenshot 2022-07-13 155349.png
    15.8 KB · Views: 9

bebo021999

Well-known Member
Joined
Jul 14, 2011
Messages
2,052
Office Version
  1. 2016
In my previous code, replace
VBA Code:
For i = 1 To k
        Range(arr(i, 1)).Rows.Group
Next
by
VBA Code:
For i = 1 To k
        Range(arr(i, 1)).interior.colorindex = 3' change 3 to whatever color you want
Next
does it work>?
 
Upvote 0

Excel Facts

Format cells as time
Select range and press Ctrl+Shift+2 to format cells as time. (Shift 2 is the @ sign).

austinandreikurt

Board Regular
Joined
Aug 25, 2020
Messages
80
Office Version
  1. 2016
Platform
  1. Windows
Hi @bebo021999 yes, but the way it colors should be change. Attaching the macro result vs the should be result.
 

Attachments

  • Screenshot 2022-07-14 180535.png
    Screenshot 2022-07-14 180535.png
    22 KB · Views: 4
Upvote 0

jaeiow

Board Regular
Joined
Jun 12, 2022
Messages
123
Office Version
  1. 365
Platform
  1. Windows
I would simply offset by one row down.
VBA Code:
For i = 1 To k
Range(arr(i, 1)).Offset(1, 0).interior.colorindex = 3' change 3 to whatever color you want
Next
 
Upvote 0

austinandreikurt

Board Regular
Joined
Aug 25, 2020
Messages
80
Office Version
  1. 2016
Platform
  1. Windows
@jaeiow that makes the difference! Now I got the complete code with the Summarize Rows Above Detail as below. Thanks a lot for your help @bebo021999 and @jaeiow ! (y)(y)(y)

VBA Code:
Option Explicit
Sub test()
    With ActiveSheet.Outline
        .AutomaticStyles = False
        .SummaryRow = xlAbove
        .SummaryColumn = xlRight
    End With

On Error Resume Next
Dim lr&, k&, i&, cell As Range, StartC As String, endC As String, arr(1 To 10000, 1 To 1)
lr = Cells(Rows.Count, "A").End(xlUp).Row
With WorksheetFunction
    For Each cell In Range("A1:A" & lr)
        If Not IsEmpty(cell) And cell.Value <> 0 And .CountIf(Range("A1:A" & lr), cell) > 1 Then
            If .CountIf(Range("A1", cell.Offset(-1, 0)), cell) = 0 Then
                StartC = cell.Address(0, 0)
            ElseIf .CountIf(Range(cell.Offset(1, 0), Cells(lr, 1)), cell) = 1 Then
                endC = cell.Address(0, 0)
            End If
        End If
        If endC <> "" Then
            k = k + 1
            arr(k, 1) = StartC & ":" & endC
            StartC = "": endC = ""
        End If
    Next
    For i = 1 To k
        Range(arr(i, 1)).Offset(1, 0).Rows.Group
    Next
End With
End Sub
 
Upvote 0

austinandreikurt

Board Regular
Joined
Aug 25, 2020
Messages
80
Office Version
  1. 2016
Platform
  1. Windows
Sorry, there's just one last problem on this. It does not group if there is only one duplicate. It should only ignore if there is no duplicate but once there is one or more, it should always group or color.
 

Attachments

  • Only 1 duplicate.png
    Only 1 duplicate.png
    12.7 KB · Views: 2
Upvote 0

austinandreikurt

Board Regular
Joined
Aug 25, 2020
Messages
80
Office Version
  1. 2016
Platform
  1. Windows
I tried editing spotting where to change the code so that even values with just one duplicate will also be colored/grouped but still no luck as it only functions on values with 2 or more duplicates. Appreciate the help on this!
 
Upvote 0

austinandreikurt

Board Regular
Joined
Aug 25, 2020
Messages
80
Office Version
  1. 2016
Platform
  1. Windows
Just to close this query, I created a simple solution on the single duplicate issue that is not being grouped by just adding another ElseIf. Below is the final codes and thanks to @jaeiow's input and the original codes of @bebo021999 since I just modified it for only a bit.
VBA Code:
Option Explicit
Sub test()
    With ActiveSheet.Outline
        .AutomaticStyles = False
        .SummaryRow = xlAbove
        .SummaryColumn = xlRight
    End With

On Error Resume Next
Dim lr&, k&, i&, cell As Range, StartC As String, endC As String, arr(1 To 10000, 1 To 1)
lr = Cells(Rows.Count, "A").End(xlUp).Row
With WorksheetFunction
    For Each cell In Range("A1:A" & lr)
        If Not IsEmpty(cell) And cell.Value <> 0 And .CountIf(Range("A1:A" & lr), cell) > 1 Then
            If .CountIf(Range("A1", cell.Offset(-1, 0)), cell) = 0 Then
                StartC = cell.Address(0, 0)
            ElseIf .CountIf(Range(cell.Offset(1, 0), Cells(lr, 1)), cell) = 1 Then
                endC = cell.Address(0, 0)
            ElseIf .CountIf(Range(cell, cell.Offset(-1, 0)), cell) = 2 And .CountIf(Range("A1", Cells(lr, 1)), cell) = 2 Then
                cell.Rows.Group
            End If
        End If
        If endC <> "" Then
            k = k + 1
            arr(k, 1) = StartC & ":" & endC
            StartC = "": endC = ""
        End If
    Next
    For i = 1 To k
        Range(arr(i, 1)).Offset(1, 0).Rows.Group
    Next
End With
End Sub
 
Upvote 0
Solution

Forum statistics

Threads
1,187,025
Messages
5,961,165
Members
438,520
Latest member
annamemma

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top