VBA to Group Rows Based on Same Values

[austinandreikurt]

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
7	0
8	0
9	0
10	0
11	1
12	2
13	2
14	2
15	3
16	3
17	3
18	3
19	3
20	3
21	3
22	3
23	3
24	3
25	4
26	4
27	4
28	4
29	5
30	5
31	5
32	5
33	5
34	5
35	5
36	5
37	5
38	6
39	6
40	6
41	6
42	6
43	7
44	8
45	8
46	8
47	8
48	8
49	8
50	8
51	8
52	8
53	8
54	9
55	9
56	9
57	9
58	9
59	9
60	9
61	9
62	9
63	9
64	9
Sheet1

 

[bebo021999]

In my previous code, replace

For i = 1 To k
        Range(arr(i, 1)).Rows.Group
Next

by

For i = 1 To k
        Range(arr(i, 1)).interior.colorindex = 3' change 3 to whatever color you want
Next

does it work>?

 

[austinandreikurt]

Hi @bebo021999 yes, but the way it colors should be change. Attaching the macro result vs the should be result.

 

[jaeiow]

I would simply offset by one row down.

For i = 1 To k
Range(arr(i, 1)).Offset(1, 0).interior.colorindex = 3' change 3 to whatever color you want
Next

 

[austinandreikurt]

@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 !

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

 

[austinandreikurt]

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.

 

[austinandreikurt]

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!

 

[austinandreikurt]

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.

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