PDA

View Full Version : Make report summary using VBA arrays



YasserKhalil
10-19-2016, 01:57 PM
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
10-20-2016, 03:47 AM
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
10-20-2016, 04:24 AM
That's great Mr. MickG .. Really fascinating
Thank you very much for help
Best Regards

MickG
10-21-2016, 03:52 AM
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
10-21-2016, 04:29 AM
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
10-21-2016, 08:34 AM
You're welcome