Grup and subtotal in VBA

O

Orhan

Hi

What I need to do is to make in vba subtotal of a big list (19000 rows)


store val1 val2 val3 id name

MAGAZIN 1 (1) 42.00 45.45 34.46 119 BA ALC CONIAC, BRANDY (119)
MAGAZIN 1 (1) 18.64 34.80 10.60 119 BA ALC CONIAC, BRANDY (119)
MAGAZIN 1 (1) 27.00 47.50 12.92 119 BA ALC CONIAC, BRANDY (119)
MAGAZIN 1 (1) 26.90 42.00 8.40 119 BA ALC CONIAC, BRANDY (119)
MAGAZIN 1 (1) 45.53 70.00 13.29 123 BA ALC LICHIOR (123)
MAGAZIN 1 (1) 23.00 33.60 5.24 123 BA ALC LICHIOR (123)
MAGAZIN 2 (2) 9.80 15.20 2.98 119 BA ALC CONIAC, BRANDY (119)
MAGAZIN 2 (2) 21.50 33.00 6.23 119 BA ALC CONIAC, BRANDY (119)
MAGAZIN 2 (2) 77.11 56.00 36.34 119 BA ALC CONIAC, BRANDY (119)
MAGAZIN 2 (2) 32.77 59.20 16.98 119 BA ALC CONIAC, BRANDY (119)
MAGAZIN 2 (2) 6.30 9.70 1.85 119 BA ALC CONIAC, BRANDY (119)
MAGAZIN 2 (2) 45.53 70.00 13.29 123 BA ALC LICHIOR (123)
MAGAZIN 2 (2) 23.00 33.60 5.24 123 BA ALC LICHIOR (123)

I need to grup by store name and subtotal val1, val2, val3 by id
The result I want looks like this:

MAGAZIN 1 (1) 114.54 169.75 66.38 119 BA ALC CONIAC, BRANDY (119)
MAGAZIN 1 (1) 68.53 103.60 18.53 123 BA ALC LICHIOR (123)
MAGAZIN 2 (2) 147.48 173.10 64.38 119 BA ALC CONIAC, BRANDY (119)
MAGAZIN 2 (2) 68.53 103.60 18.53 123 BA ALC LICHIOR (123)


Any help apreciated!
 
U

Udo

Hi,

first of all, you have to be sure that the list is sorted by the items
which should be grouped. In case, this is not already done, the
following piece of code helps:
Assume, the whole list is selected and the last active cell is on the
first cell of "store"

Selection.Sort Key1:=ActiveCell.Offset(0,4), Order1:=xlAscending,
Header:=xlNo, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom

Then the grouping and subtotalling is done by

Selection.Subtotal GroupBy:=5, Function:=xlSum, TotalList:=Array(3, 4,
5), _
Replace:=False, PageBreaks:=False, SummaryBelowData:=True

Good luck
Udo
 
O

Orhan

Hi,

I run the macro, but my computer crashes, so anyway I found this one
witch works

Sub sub_total()
iLastRow = Cells(Rows.Count, "g").End(xlUp).Row
iTotal = iLastRow
For i = iLastRow To 2 Step -1
If Cells(i, "g").Value <> Cells(i - 1, "g").Value Then
Rows(iTotal + 1).Insert
Cells(iTotal + 1, "k").Formula = _
"=SUM(D" & i & ":D" & iTotal & ")"
iTotal = i - 1
End If
Next i
End Sub


It inserts a new row with subtotal after each group.
But how can I delete the rest and keep only the subtotal row?

Thanls!
 
U

Udo

Hi Orhan,

the easiest way is to copy the subtotals row and insert it again, but
only as values. If you need to do that part automatically, use
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False
ActiveSheet.Paste
Application.CutCopyMode = False

My suggestion would be not to delete the details, but copy values of
the subtotals row into a kind of consolidation worksheet which is
different from the calculation sheet. That could be - for the sake of
file size - another file, you could also use a separate sheet.

Good luck
Udo
 
U

Udo

Hi Orhan,

the easiest way is to copy the subtotals row and insert it again, but
only as values. If you need to do that part automatically, use
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False
ActiveSheet.Paste
Application.CutCopyMode = False

My suggestion would be not to delete the details, but copy values of
the subtotals row into a kind of consolidation worksheet which is
different from the calculation sheet. That could be - for the sake of
file size - another file, you could also use a separate sheet.

Good luck
Udo
 
G

Guest

Try this ...

=============================================
Dim store, tval1, tval2, tval3, id, name
Sub Naveen3()
store = ""
tval1 = 0
tval2 = 0
tval3 = 0
id = ""
name = ""
lastrow = Cells.SpecialCells(xlCellTypeLastCell).Row
absrow = lastrow + 2

tval1 = Cells(2, 2)
tval2 = Cells(2, 3)
tval3 = Cells(2, 4)

For i = 2 To lastrow
If Cells(i + 1, 1) = Cells(i, 1) And Cells(i + 1, 6) = Cells(i, 6) Then
tval1 = tval1 + Cells(i + 1, 2)
tval2 = tval2 + Cells(i + 1, 3)
tval3 = tval3 + Cells(i + 1, 4)
Else
Cells(absrow, 1) = Cells(i, 1)
Cells(absrow, 2) = tval1
Cells(absrow, 3) = tval2
Cells(absrow, 4) = tval3
Cells(absrow, 5) = Cells(i, 5)
Cells(absrow, 6) = Cells(i, 6)
absrow = absrow + 1
tval1 = Cells(i + 1, 2)
tval2 = Cells(i + 1, 3)
tval3 = Cells(i + 1, 4)
End If
Next i
End Sub
=================================================

*** Please do rate ***
 
G

Guest

why not use pivot table?
--
hemu


Udo said:
Hi,

first of all, you have to be sure that the list is sorted by the items
which should be grouped. In case, this is not already done, the
following piece of code helps:
Assume, the whole list is selected and the last active cell is on the
first cell of "store"

Selection.Sort Key1:=ActiveCell.Offset(0,4), Order1:=xlAscending,
Header:=xlNo, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom

Then the grouping and subtotalling is done by

Selection.Subtotal GroupBy:=5, Function:=xlSum, TotalList:=Array(3, 4,
5), _
Replace:=False, PageBreaks:=False, SummaryBelowData:=True

Good luck
Udo
Click to expand...
 
O

Orhan

I used this one for subtotals

Sub sub_total()

Dim iLastRow As Long
Dim iTotal As Long
Dim i As Long

iLastRow = Cells(Rows.Count, "g").End(xlUp).Row
iTotal = iLastRow
For i = iLastRow To 2 Step -1
If Cells(i, "g").Value <> Cells(i - 1, "g").Value Then
Rows(iTotal + 1).Insert
Cells(iTotal + 1, "k").Formula = _
"=SUM(D" & i & ":D" & iTotal & ")"

Cells(iTotal + 1, "i").Value = _
"1"

iTotal = i - 1
End If
Next i
End Sub


On the Subtotal row I added "1" on "i" column, then I filtred the rows
on "1" column and deleted the rest.

Thanks for sugestions!
 
O

Orhan

For filter and delete I used this code

------------------------------------------------------------------

Dim rng As Range

Columns("I:I").Select
ActiveWorkbook.Names.Add name:="ListNames",
RefersToR1C1:="=Raport!C9"


Application.Goto Reference:="ListNames" 'Range for names

Selection.AutoFilter
Selection.AutoFilter Field:=1, _
Criteria1:="<>1"

Set rng = ActiveSheet.AutoFilter.Range
Set rng = rng.Offset(1, 0).Resize(rng.Rows.Count - 1)
Set rng = rng.Columns(1).SpecialCells(xlVisible).EntireRow
rng.Delete
ActiveSheet.AutoFilterMode = False


Dim wsNew As Worksheet

Set wsNew = Worksheets.Add(After:=Worksheets(Worksheets.Count))

wsNew.name = "Supergrupa"

Sheets("Raport").Select
ActiveSheet.UsedRange.Select
Selection.Copy
Sheets("Supergrupa").Select
ActiveSheet.Paste
Range("B:B,C:C,I:I,J:J,K:K").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Range("A1").Select

Range("A1").Value = "Magazin"
Range("B1").Value = "Val1"
Range("C1").Value = "Val2"
Range("D1").Value = "Val3"
Range("E1").Value = "Supergr_id"
Range("F1").Value = "Supergr_den"

wsNew.Columns.AutoFit

Sheets("Raport").Select
Range("B:B,C:C,I:I").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft

------------------------------------------------------------------

Because I have 16000 rows and I use this subtotal twice it takes 2
minutes to complete.

I think that there are other ways to do this job faster, but 2 minutes
is not such a long time to wait.

Bye!
 
Top