iwgunter said:
Probably VBA code, as I was hoping it would do it automatically so I
wouldn't have to keep unhiding rows etc.
Here it is:
----------------------------------------------
Sub MultiGroupData()
' Requires Microsoft DAO 3.60 Object Library
' Contributed by Norman Jones (Dictionary operation).
Dim MyDic As Object, Temp_1_Array(), Temp_2_Array()
Dim i As Long, j As Long, k As Long, n As Byte, s As Long
Dim MultipleKey As String, T As Double
Dim Sourcerange As Range, TargetRange As Range
Dim TargetStart As Range, SortMode As Boolean
Dim NumRows As Long, ColSum() As Double
Dim BC As Workspace, FrequencyCol As Byte
Dim NumCols As Byte, GroupCols As Byte, SumCols As Byte
T = Timer
' Definition
' -------------------------------------------------------------
Set Sourcerange = [Sheet10!J1:N60000]
Set TargetStart = [Sheet10!P1] 'If TargetRange = TopLeftCell
' of SourceRange, then output will overwrite SourceRange
SortMode = False ' True = Sort
' False = No Sort
' See below S O R T
FrequencyCol = 0 ' Further column containing Frequency
' 1 = Yes
' 0 = No
' Frequency data are always calculated in
' Temp_2_Array() which is REDIMed
' to NumCols + 1 (2nd dimension)
GroupCols = 2 ' Number of columns (from the left) to be
' grouped (all the other columns will be summed)
' Must be > 0
' -------------------------------------------------------------
Set BC = DBEngine.Workspaces(0)
NumRows = Sourcerange.Rows.Count
NumCols = Sourcerange.Columns.Count
SumCols = NumCols - GroupCols
If SumCols > 0 Then
ReDim ColSum(1 To SumCols)
End If
Set TargetRange = Range(TargetStart, TargetStart(NumRows, NumCols +
FrequencyCol))
ReDim Temp_2_Array(1 To NumRows, 1 To NumCols + 1)
On Error GoTo ErrHandler
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Set MyDic = CreateObject("Scripting.Dictionary")
Temp_1_Array() = Sourcerange
For i = LBound(Temp_1_Array) To UBound(Temp_1_Array)
MultipleKey = ""
For j = 1 To GroupCols
MultipleKey = MultipleKey & UCase(Temp_1_Array(i, j))
Next
If MultipleKey <> "" Then
On Error GoTo Continue1
MyDic.Add MultipleKey, i
On Error GoTo ErrHandler
k = k + 1
For n = 1 To SumCols
ColSum(n) = Temp_1_Array(i, GroupCols + n)
Next
s = 0
For j = 1 To GroupCols
Temp_2_Array(k, j) = Temp_1_Array(i, j)
Next
End If
Continue2:
Temp_2_Array(k, NumCols + 1) = s + 1
For n = 1 To SumCols
Temp_2_Array(k, GroupCols + n) = ColSum(n)
Next
Next
On Error GoTo Roll_Back
BC.BeginTrans
TargetRange.ClearContents
TargetRange = Temp_2_Array()
BC.CommitTrans
On Error GoTo ErrHandler
' S O R T
' -------
' Set KeyX, OrderX accordingly (Max 3 Keys & Orders)
If SortMode Then
TargetRange.Sort _
Key1:=TargetStart(1, 6), _
Order1:=xlDescending, _
Key2:=TargetStart(1, 1), _
Order2:=xlAscending, _
Key3:=TargetStart(1, 2), _
Order3:=xlAscending, _
MatchCase:=True
End If
Exit_Sub:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox Timer - T
Exit Sub
ErrHandler:
MsgBox "Error " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
"Procedure: Sub MultiGroupData()" & vbCrLf & ThisWorkbook.FullName
Resume Exit_Sub
Continue1:
s = s + 1
For n = 1 To SumCols
ColSum(n) = ColSum(n) + Temp_1_Array(i, GroupCols + n)
Next
Resume Continue2
Roll_Back:
BC.Rollback
Resume ErrHandler
End Sub
---------------------------------------------
It does more things then needed.
You must only write 5 definitions.
Ask for any further explanation.
Ciao
Bruno
