Make report summary using VBA arrays

[YasserKhalil]

Hello everyone
I have some data in range("C4:F16") .. column C is for gender (Male / Female / Couple (for both))
Column D is Color - Column E for Male sales & Column F for Female sales

I need to make a report or reformat the data in another format . I have attached the whole desired output in range("I3:N13")
If it is possible I need the same formats for headings .. To leave blank row between each color report .. to make the headers of each group in bold .. the first cell of each group in red so as to be easily shown

Note : The colours are dynamic so the number of groups will be dynamic
Hope it is clear

Thanks advanced for help

[MickG]

Try this for results starting "I3"
There is no formatting at the moment, as I have to go out !!!

Sub RngMod()
Dim oHds As Variant, Dn As Range, temp As String, Rng As Range
Dim Dic As Object, R As Long, Q As Variant, Ray As Variant
Dim Col As Integer, Txt As String, Ac As Long
Dim Cc As Long, k As Variant
Dim p As Variant, c As Long, Sp As Variant
    Set Rng = Range(Range("D4"), Range("D" & Rows.Count).End(xlUp))
        oHds = Array("S", "M", "L", "XL", "XXL")
            ReDim Ray(1 To Rng.Count * 2, 1 To 6)
Set Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
   For Each Dn In Rng
            If Not Dic.exists(Dn.Value) Then
                Set Dic(Dn.Value) = CreateObject("Scripting.Dictionary")
            End If
        For Col = 1 To 2
            If Dn.Offset(, Col) <> "" Then
                Txt = Trim(Dn.Offset(, Col)) & "," & Rng(1).Offset(-1, Col)
                If Not Dic(Dn.Value).exists(Txt) Then
                    Dic(Dn.Value).Add (Txt), 1
                Else
                    Dic(Dn.Value).Item(Txt) = _
                    Dic(Dn.Value).Item(Txt) + 1
                End If
            End If
     Next Col
    Next Dn
   
    
For Each k In Dic.Keys
        c = c + 1: temp = c
        For Ac = 1 To 6
            If Ac = 1 Then
                Ray(c, Ac) = k
            Else
                Ray(c, Ac) = oHds(Ac - 2)
            End If
        Next Ac
            c = c + 1
            For Each p In Dic(k)
               Sp = Split(p, ",")
               R = IIf(Sp(1) = "Female", c + 1, c)
               Cc = Application.Match(Trim(Sp(0)), oHds, 0) + 1
               Ray(R, Cc) = Dic(k).Item(p)
               Ray(R, 1) = Sp(1)
            Next p
    c = temp + 3
    Next k
Range("I3").Resize(c, 6) = Ray
End Sub

[YasserKhalil]

That's great Mr. MickG .. Really fascinating
Thank you very much for help
Best Regards

[MickG]

This is basically the same code but with formatting.
Hope that helps !!

Sub RngMod()
Dim oHds As Variant, Dn As Range, temp As String, Rng As Range
Dim Dic As Object, R As Long, Q As Variant, Ray As Variant
Dim Col As Integer, Txt As String, Ac As Long
Dim Cc As Long, k As Variant
Dim p As Variant, c As Long, Sp As Variant
 Range("I:N").Clear
    Set Rng = Range(Range("D4"), Range("D" & Rows.Count).End(xlUp))
        oHds = Array("S", "M", "L", "XL", "XXL")
            ReDim Ray(1 To Rng.Count * 2, 1 To 6)
Set Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
   For Each Dn In Rng
            If Not Dic.exists(Dn.Value) Then
                Set Dic(Dn.Value) = CreateObject("Scripting.Dictionary")
            End If
        For Col = 1 To 2
            If Dn.Offset(, Col) <> "" Then
                Txt = Trim(Dn.Offset(, Col)) & "," & Rng(1).Offset(-1, Col)
                If Not Dic(Dn.Value).exists(Txt) Then
                    Dic(Dn.Value).Add (Txt), 1
                Else
                    Dic(Dn.Value).Item(Txt) = _
                    Dic(Dn.Value).Item(Txt) + 1
                End If
            End If
     Next Col
    Next Dn
   
    
For Each k In Dic.Keys
        c = c + 1: temp = c
        For Ac = 1 To 6
            If Ac = 1 Then
                Ray(c, Ac) = k
            Else
                Ray(c, Ac) = oHds(Ac - 2)
            End If
        Next Ac
            c = c + 1
            For Each p In Dic(k)
               Sp = Split(p, ",")
               R = IIf(Sp(1) = "Female", c + 1, c)
               Cc = Application.Match(Trim(Sp(0)), oHds, 0) + 1
               Ray(R, Cc) = Dic(k).Item(p)
               Ray(R, 1) = Sp(1)
            Next p
    c = temp + 3
    Next k
 With Range("I3").Resize(c, 6)
    .Value = Ray
    .Borders.Weight = 2 ' Remove if not required !!!
 End With
For Each Dn In Range("I3:I" & c)
If Dic.exists(Dn.Value) Then
  With Dn.Resize(, 6)
    .Interior.Color = 10086143
    .Font.Color = 0
    .Font.Size = 11
    .Font.Bold = True
  End With
    Dn.Font.Color = 255
End If
Next Dn
End Sub

[YasserKhalil]

That's very kind of you. Thank you very much for this perfect solution
Thanks a lot for great and fascinating help
Best Regards

[MickG]

You're welcome