Subtotal macro for multiple columns

August 25, 2016 at 09:12:32
Specs: Windows 7
I have a sheet(Excel Spreadsheet) with 31 Columns til "AE" what I am looking for is from the 31 columns if data is same in columns in G,H,J then it have to do a subtotal by sum in column k, M,N, Q

say it have to concatenate columns G,H,J and put the result in column AF sort by column AF and do a sum for columns k, M,N, and Q

I have found the below code from net it does what i want but for column abc and def but what i am looking for is the same for G,Hand J instead of abc and K,M,N,Q instead of DEF

below is the code

<Option Explicit
Sub ReArrangeData()
Dim sws As Worksheet, dws As Worksheet
Dim lr As Long, i As Long
Dim rng As Range, cell As Range
Application.ScreenUpdating = False
Set sws = Sheets("Sheet1")
Set dws = Sheets("Output")
sws.Range("A1").CurrentRegion.Copy dws.Range("A1")
'dws.Range("A1").CurrentRegion.Sort key1:=dws.Range("A1"), order1:=xlAscending, key2:=dws.Range("B1"), order2:=xlAscending, key3:=dws.Range("C1"), order3:=xlAscending, Header:=xlGuess
lr = dws.Cells(Rows.Count, 1).End(xlUp).Row
Range("G2:G" & lr).Formula = "=A2&B2&C2"
dws.Range("A1").CurrentRegion.Sort key1:=dws.Range("G1"), order1:=xlAscending, Header:=xlGuess
dws.Range("H2:H" & lr).Formula = "=IF(OR(G2=G3,G2=G1),0,1)"
dws.Range("H1").Value = "Formula"
dws.Range("H2:H" & lr).Value = Range("H2:H" & lr).Value
dws.Range("A1").CurrentRegion.Sort key1:=dws.Range("H1"), order1:=xlAscending, Header:=xlYes
For i = lr To 3 Step -1
If dws.Cells(i, 7) = dws.Cells(i - 1, 7) And dws.Cells(i, 8) <> 1 Then
dws.Rows(i + 1).Insert
End If
Next i
lr = dws.Cells(Rows.Count, 1).End(xlUp).Row + 1
For Each rng In dws.Range("D1:D" & lr).SpecialCells(xlCellTypeConstants).Areas
If rng.Cells(rng.Rows.Count).Offset(0, 4) = 0 Then
rng.Cells(rng.Rows.Count).Offset(1, -1) = "Total"
rng.Cells(rng.Rows.Count).Offset(1, 0) = Application.Sum(rng)
rng.Cells(rng.Rows.Count).Offset(1, 1) = Application.Sum(rng.Offset(0, 1))
rng.Cells(rng.Rows.Count).Offset(1, 2) = Application.Sum(rng.Offset(0, 2))
rng.Cells(rng.Rows.Count).Offset(1, -1).Resize(1, 4).Font.Bold = True
rng.Offset(0, -3).Resize(rng.Rows.Count, 6).Interior.Color = RGB(146, 208, 80)
rng.Cells(rng.Rows.Count).Offset(1, -3).Resize(1, 6).Interior.Color = RGB(0, 176, 80)
rng.Cells(rng.Rows.Count).Offset(1, -3).Resize(1, 2).Borders.LineStyle = xlNone
End If
Next rng
dws.Rows(1).Interior.ColorIndex = xlNone
Application.ScreenUpdating = True
End Sub>

See More: Subtotal macro for multiple columns

Reply ↓  Report •

Related Solutions

Ask Question