subtotalling records

C

Cyberwolf

I have a spreadsheet that I add codes to each morning See example below. What
I currently do is place a list at the bottom of the spreadsheet and then
loop through each record and subtotal based on each diffrent description in
the list. I currently have a static list of codes that get used regulalry.
What I want to do is get rid of the static list and create a dynamic list
based on what is used in the spreadsheet each day. I have included the code
for the static subtotalling.

Here is the spreadsheet

Ref No Debit Reason Desc 2
103312424 - 1,343.61 - 092 15 CM RET
3899862 - 211.20 - 021 06 CM CJX
4000502 - 153.32 - 021 06 CM SUB
4001088 - 137.94 - 092 06 CM CJX
4011306 - 20.00 - 092 06 CM CS
4011448 - 10.00 - 025 A9 CM PJA
4012160 - 90.00 - 092 A9 CM RET
4015083 - 23.96 - 092 06 CM CS
4016002 - 60.00 - 092 A9 CM PJA

I am currently sorting and subtotalling based on the Desc2 field

Here is the static list at the bottom of the spreadsheet

- NA
70.00 PJA
- PJX
- PLA
- POP
- SJA
- SJX
- SLA
- SOP
43.96 GL#81559 CS
- GL#81558 CJ
- GL#81560 LA
- GL#84265 OP
308.11 GL#81640 LT
- CJA
349.14 CJX
- CLA
- COP
- MD
- NB
- EU
- BA
- UCUA
- PPO
- WMT
- NP
- DUP
- UPS
- AR
153.32 SUB
- TKT
- MBI
- OCP
- LL-DSDC
- LL-DTS
- COPY
- LC
1,433.61 RET
- FCA
- AD
- SM
- SO
2,050.03
2,050.03
-
- REF

As you can see I only used a few of these codes.

Here is the code I use to do this

Sub SumCB()
'On Error GoTo SumCB_Err

Dim dblNA As Double
Dim dblPJA As Double
Dim dblPJX As Double
Dim dblPLA As Double
Dim dblPOP As Double
Dim dblSJA As Double
Dim dblSJX As Double
Dim dblSLA As Double
Dim dblSOP As Double
Dim dblCS As Double
Dim dblCJ As Double
Dim dblLA As Double
Dim dblOP As Double
Dim dblCJA As Double
Dim dblCJX As Double
Dim dblCLA As Double
Dim dblCOP As Double
Dim dblMD As Double
Dim dblNB As Double
Dim dblEU As Double
Dim dblBA As Double
Dim dblUCUA As Double
Dim dblWMT As Double
Dim dblNP As Double
Dim dblDUP As Double
Dim dblUPS As Double
Dim dblAR As Double
Dim dblSUB As Double
Dim dblTKT As Double
Dim dblMBI As Double
Dim dblOCP As Double
Dim dblLLDSDC As Double
Dim dblLLDTS As Double
Dim dblCOPY As Double
Dim dblLC As Double
Dim dblRET As Double
'Dim dblLT As Double
Dim dblFCA As Double
Dim dblSM As Double
Dim dblSO As Double
Dim dblAD As Double
Dim dblOTHER As Double
Dim dblREF As Double
Dim A As Worksheet
Dim R As Range
Dim X As Integer
Dim varRng As Variant
Dim Ref As Integer
Dim dblTotal As Double
Dim dblConc As Double
Dim dblPPO As Double
Dim stChkNo As String
Dim stChkDte As String

Set A = Worksheets(1)
Set R = A.UsedRange.Cells
varRng = R.Rows.Count



' Adds up all of the chargebacks by type

Ref = 2
For Each C In Worksheets(1).Range("M2:M" & varRng - 45)
If C = "NA" Then dblNA = dblNA + Range("G" & Ref)
If C = "NA" Then
Rows(Ref).Select
With Selection.Interior
.ColorIndex = 4
.Pattern = xlSolid
End With
End If
If C = "AR" Then dblAR = dblAR + Range("G" & Ref)
If C = "AR" Then
Rows(Ref).Select
With Selection.Interior
.ColorIndex = 4
.Pattern = xlSolid
End With
End If
If C = "PJA" Then dblPJA = dblPJA + Range("G" & Ref)
If C = "PJX" Then dblPJX = dblPJX + Range("G" & Ref)
If C = "PLA" Then dblPLA = dblPLA + Range("G" & Ref)
If C = "POP" Then dblPOP = dblPOP + Range("G" & Ref)
If C = "SJA" Then dblSJA = dblSJA + Range("G" & Ref)
If C = "SJX" Then dblSJX = dblSJX + Range("G" & Ref)
If C = "SLA" Then dblSLA = dblSLA + Range("G" & Ref)
If C = "SOP" Then dblSOP = dblSOP + Range("G" & Ref)
If C = "CS" Then dblCS = dblCS + Range("G" & Ref)
If C = "CJ" Then dblCJ = dblCJ + Range("G" & Ref)
If C = "LA" Then dblLA = dblLA + Range("G" & Ref)
If C = "OP" Then dblOP = dblOP + Range("G" & Ref)
If C = "MD" Then dblMD = dblMD + Range("G" & Ref)
If C = "NB" Then dblNB = dblNB + Range("G" & Ref)
If C = "EU" Then dblEU = dblEU + Range("G" & Ref)
If C = "CJA" Then dblCJA = dblCJA + Range("G" & Ref)
If C = "CJX" Then dblCJX = dblCJX + Range("G" & Ref)
If C = "CLA" Then dblCLA = dblCLA + Range("G" & Ref)
If C = "COP" Then dblCOP = dblCOP + Range("G" & Ref)
If C = "BA" Then dblBA = dblBA + Range("G" & Ref)
If C = "UCUA" Then dblUCUA = dblUCUA + Range("G" & Ref)
If C = "UCUA" Then
Rows(Ref).Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
End If
If C = "PPO" Then dblPPO = dblPPO + Range("G" & Ref)
If C = "WMT" Then dblWMT = dblWMT + Range("G" & Ref)
If C = "NP" Then dblNP = dblNP + Range("G" & Ref)
If C = "DUP" Then dblDUP = dblDUP + Range("G" & Ref)
If C = "UPS" Then dblUPS = dblUPS + Range("G" & Ref)
If C = "SUB" Then dblSUB = dblSUB + Range("G" & Ref)
If C = "TKT" Then dblTKT = dblTKT + Range("G" & Ref)
If C = "MBI" Then dblMBI = dblMBI + Range("G" & Ref)
If C = "OCP" Then dblOCP = dblOCP + Range("G" & Ref)
If C = "LL-DSDC" Then dblLLDSDC = dblLLDSDC + Range("G" & Ref)
If C = "LL-DTS" Then dblLLDTS = dblLLDTS + Range("G" & Ref)
If C = "COPY" Then dblCOPY = dblCOPY + Range("G" & Ref)
If C = "LC" Then dblLC = dblLC + Range("G" & Ref)
' If C = "LT" Then dblLT = dblLT + Range("G" & Ref)
If C = "RET" Then dblRET = dblRET + Range("G" & Ref)
If C = "FCA" Then dblFCA = dblFCA + Range("G" & Ref)
If C = "SM" Then dblSM = dblSM + Range("G" & Ref)
If C = "SO" Then dblSO = dblSO + Range("G" & Ref)
If C = "AD" Then dblAD = dblAD + Range("G" & Ref)
If C = "AD" Then
Rows(Ref).Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
End If
If C = "OTHER" Then dblOTHER = dblOTHER + Range("G" & Ref)
If C = "REF" Then dblREF = dblREF + Range("I" & Ref)

Ref = Ref + 1
Next C

' Places the Chargeback totals in their respective fields

Range("I" & varRng - 45).Select
ActiveCell.FormulaR1C1 = dblNA
Range("I" & varRng - 44).Select
ActiveCell.FormulaR1C1 = dblPJA
Range("I" & varRng - 43).Select
ActiveCell.FormulaR1C1 = dblPJX
Range("I" & varRng - 42).Select
ActiveCell.FormulaR1C1 = dblPLA
Range("I" & varRng - 41).Select
ActiveCell.FormulaR1C1 = dblPOP
Range("I" & varRng - 40).Select
ActiveCell.FormulaR1C1 = dblSJA
Range("I" & varRng - 39).Select
ActiveCell.FormulaR1C1 = dblSJX
Range("I" & varRng - 38).Select
ActiveCell.FormulaR1C1 = dblSLA
Range("I" & varRng - 37).Select
ActiveCell.FormulaR1C1 = dblSOP
Range("I" & varRng - 36).Select
ActiveCell.FormulaR1C1 = dblCS
Range("I" & varRng - 35).Select
ActiveCell.FormulaR1C1 = dblCJ
Range("I" & varRng - 34).Select
ActiveCell.FormulaR1C1 = dblLA
Range("I" & varRng - 33).Select
ActiveCell.FormulaR1C1 = dblOP
dblConc = dblCS + dblCJ + dblLA + dblOP
Range("G" & varRng - 32).Select
ActiveCell.FormulaR1C1 = dblConc
Selection.Font.Bold = True
'Range("I" & varRng - 6).Select
'ActiveCell.FormulaR1C1 = dblLT
Range("I" & varRng - 31).Select
ActiveCell.FormulaR1C1 = dblCJA
Range("I" & varRng - 30).Select
ActiveCell.FormulaR1C1 = dblCJX
Range("I" & varRng - 29).Select
ActiveCell.FormulaR1C1 = dblCLA
Range("I" & varRng - 28).Select
ActiveCell.FormulaR1C1 = dblCOP
Range("I" & varRng - 27).Select
ActiveCell.FormulaR1C1 = dblMD
Range("I" & varRng - 26).Select
ActiveCell.FormulaR1C1 = dblNB
Range("I" & varRng - 25).Select
ActiveCell.FormulaR1C1 = dblEU
Range("I" & varRng - 24).Select
ActiveCell.FormulaR1C1 = dblBA
Range("I" & varRng - 23).Select
ActiveCell.FormulaR1C1 = dblUCUA
Range("I" & varRng - 22).Select
ActiveCell.FormulaR1C1 = dblPPO
Range("I" & varRng - 21).Select
ActiveCell.FormulaR1C1 = dblWMT
Range("I" & varRng - 20).Select
ActiveCell.FormulaR1C1 = dblNP
Range("I" & varRng - 19).Select
ActiveCell.FormulaR1C1 = dblDUP
Range("I" & varRng - 18).Select
ActiveCell.FormulaR1C1 = dblUPS
Range("I" & varRng - 17).Select
ActiveCell.FormulaR1C1 = dblAR
Range("I" & varRng - 16).Select
ActiveCell.FormulaR1C1 = dblSUB
Range("I" & varRng - 15).Select
ActiveCell.FormulaR1C1 = dblTKT
Range("I" & varRng - 14).Select
ActiveCell.FormulaR1C1 = dblMBI
Range("I" & varRng - 13).Select
ActiveCell.FormulaR1C1 = dblOCP
Range("I" & varRng - 12).Select
ActiveCell.FormulaR1C1 = dblLLDSDC
Range("I" & varRng - 11).Select
ActiveCell.FormulaR1C1 = dblLLDTS
Range("I" & varRng - 10).Select
ActiveCell.FormulaR1C1 = dblCOPY
Range("I" & varRng - 9).Select
ActiveCell.FormulaR1C1 = dblLC
Range("I" & varRng - 8).Select
ActiveCell.FormulaR1C1 = dblRET
Range("I" & varRng - 7).Select
ActiveCell.FormulaR1C1 = dblFCA
Range("I" & varRng - 6).Select
ActiveCell.FormulaR1C1 = dblAD
Range("I" & varRng - 5).Select
ActiveCell.FormulaR1C1 = dblSM
Range("I" & varRng - 4).Select
ActiveCell.FormulaR1C1 = dblSO

'Totals all of the chargebacks
Range("I" & varRng - 3).Select
ActiveCell.FormulaR1C1 = dblPJA + dblPJX + dblPLA + dblSJA + dblSJX + dblSLA
+ dblUPS _
+ dblCS + dblCJ + dblLA + dblOP + dblMD + dblNB + dblEU + dblBA + dblUCUA +
dblPPO + dblAR + dblSUB _
+ dblTKT + dblMBI + dblOCP + dblLLDSDC + dblLLDTS + dblCOPY + dblLC + dblRET
+ dblFCA + dblAD _
+ dblOTHER + dblCJ3 + dblCS3 + dblLA3 + dblWMT + dblNP + dblDUP + dblNA +
dblCJA + dblCJX + dblCLA _
+ dblSM + dblSO + dblPOP + dblSOP + dblCOP


'The total field from the bottom of the chargebacks
Range("I" & varRng - 2).Select
ActiveCell.FormulaR1C1 = Range("G" & varRng - 50)

'The difference between the Total and Balance fields
Range("I" & varRng - 1).Select
dblTotal = Range("I" & varRng - 3) - Range("I" & varRng - 2)
ActiveCell.FormulaR1C1 = dblTotal

Range("I" & varRng).Select
ActiveCell.FormulaR1C1 = dblREF

' Renames the Sheet

'stChkNo = Range("B2")
'stChkDte = Range("A2")
' Sheets(1).Select
' Sheets(1).Name = stChkNo & " " & Left(stChkDte, 2) & Mid(stChkDte, 4, 2) _
' & Right(stChkDte, 2) & " Adj"

' Creates a copy of the original chargeback sheet

Sheets(1).Select
Sheets(1).Copy After:=Sheets(1)

Range("E2").Select
ActiveWindow.FreezePanes = False

Set A = Worksheets(2)
Set R = A.UsedRange.Cells
varRng = R.Rows.Count

' Sorts the data by Desc and Ref No

Rows("1:1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Sort Key1:=Range("M2"), Order1:=xlAscending, Key2:=Range("D2") _
, Order2:=xlAscending, Header:=xlYes, OrderCustom:=1,
MatchCase:=False _
, Orientation:=xlTopToBottom

' Places sub totals below each chargeback group

Range("A1:p" & varRng - 51).Select
Selection.Subtotal GroupBy:=13, Function:=xlSum, TotalList:=Array(7, 9), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True
'ActiveWindow.SmallScroll Down:=18
'Rows("1:1").Select

Set A = Worksheets(2)
Set R = A.UsedRange.Cells
varRng = R.Rows.Count
' Places the count of each chargeback type below each group

Range("A1:p" & varRng - 50).Select
Selection.Subtotal GroupBy:=13, Function:=xlCount, TotalList:=Array(11), _
Replace:=False, PageBreaks:=False, SummaryBelowData:=True
Range("E2").Select
ActiveWindow.FreezePanes = True

Set A = Worksheets(2)
Set R = A.UsedRange.Cells
varRng = R.Rows.Count

Range("G" & varRng - 53 & ":J" & varRng - 50).Select
Selection.Font.Bold = True


For X = varRng - 54 To 1 Step -1

'Let Z = X - 1
If Not IsDate(Range("a" & X)) Then
Range("G" & X & ":K" & X).Select
Selection.Font.Bold = True
End If

'Let X = Z - 1

Next X
Columns("I:I").EntireColumn.AutoFit
Columns("L:L").EntireColumn.AutoFit
Columns("J:J").EntireColumn.AutoFit
If fOSUserName() = "JGaylord" Then
Application.ActivePrinter = "hp deskjet 6122 series on Ne00:"
ActiveWindow.SelectedSheets.PrintOut Copies:=1, ActivePrinter:= _
"hp deskjet 6122 series on Ne00:", Collate:=True
Else
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
End If


If dblConc > 0 Then
If fOSUserName() = "JGaylord" Then
Application.ActivePrinter = "hp deskjet 6122 series on Ne00:"
Rows(varRng - 45 & ":" & varRng).Select
Selection.PrintOut Copies:=2, ActivePrinter:= _
"hp deskjet 6122 series on Ne00:", Collate:=True
Else
Rows(varRng - 45 & ":" & varRng).Select
Selection.PrintOut Copies:=2, Collate:=True
End If

End If


Sheets(1).Select
Sheets(1).Copy After:=Sheets(2)

Range("E2").Select
ActiveWindow.FreezePanes = False

Set A = Worksheets(3)
Set R = A.UsedRange.Cells
varRng = R.Rows.Count

' Sorts the data by Desc and Ref No

Rows("1:1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Sort Key1:=Range("M2"), Order1:=xlAscending, Key2:=Range("D2") _
, Order2:=xlAscending, Header:=xlYes, OrderCustom:=1,
MatchCase:=False _
, Orientation:=xlTopToBottom

' Places sub totals below each chargeback group

Range("A1:p" & varRng - 51).Select
Selection.Subtotal GroupBy:=13, Function:=xlSum, TotalList:=Array(7, 9), _
Replace:=True, PageBreaks:=True, SummaryBelowData:=True
'ActiveWindow.SmallScroll Down:=18
'Rows("1:1").Select

Set A = Worksheets(3)
Set R = A.UsedRange.Cells
varRng = R.Rows.Count
' Places the count of each chargeback type below each group

Range("A1:p" & varRng - 50).Select
Selection.Subtotal GroupBy:=13, Function:=xlCount, TotalList:=Array(11), _
Replace:=False, PageBreaks:=False, SummaryBelowData:=True
Range("E2").Select
ActiveWindow.FreezePanes = True

Set A = Worksheets(3)
Set R = A.UsedRange.Cells
varRng = R.Rows.Count

Range("G" & varRng - 53 & ":J" & varRng - 50).Select
Selection.Font.Bold = True


For X = varRng - 54 To 1 Step -1

'Let Z = X - 1
If Not IsDate(Range("a" & X)) Then
Range("G" & X & ":K" & X).Select
Selection.Font.Bold = True
End If

'Let X = Z - 1

Next X
Columns("I:I").EntireColumn.AutoFit
Columns("L:L").EntireColumn.AutoFit
Columns("J:J").EntireColumn.AutoFit

If fOSUserName() = "JGaylord" Then
Application.ActivePrinter = "hp deskjet 6122 series on Ne00:"
Rows(1 & ":" & varRng - 53).Select
ActiveWindow.SelectedSheets.PrintOut Copies:=1, ActivePrinter:= _
"hp deskjet 6122 series on Ne00:", Collate:=True
Else
Selection.PrintOut Copies:=1, Collate:=True
ActiveWindow.SelectedSheets.Delete
End If

'SumCB_Exit:
'Exit Sub

'SumCB_Err:
'MsgBox Err.Number
'Resume SumCB_Exit

End Sub
 
M

michael.beckinsale

Cyberwolf,

If i'm reading you right (the column layout gets distorted upon
posting) the code seems to be excessive for what you are trying to do.

Would any of the following be sufficient for your needs?

1) Sort table (spreadsheet) by Desc2 then apply sub-totals
or
2) Create unique list from Desc2 then apply SumIf formula

Both the above can be easily achieved either by using Excels built in
functionality or VBA code.

If any of the above meets your need let me know and l can probably give
you some code


Regards

Michael Beckinsale
 
C

Cyberwolf

I know my code was very bulky. The 2nd option you mentioned seams the
direction I want to go in. If you can give me something to look at I could
go from there. I am already sorting and subtotalling by desc 2. This is
done at the bottom of the VBA code.


-
Cyberwolf
Finder of Paths, Hunter of Prey
Ghost of the Night, Shadow of Day
The Wolf
 
T

Tom Ogilvy

Assume the Desc column is column D ( 4th column). Assume you want the list
of uniques in A500, Then:

Sub MakeUniqueList()
Dim rng as Range
set rng = Range(cells(1,4),cells(1,4).End(xldown))
rng.AdvancedFilterAction:=xlFilterCopy, _
CopyToRange:=Range("A500"), _
Unique:=True
end Sub
 
C

Cyberwolf

This is not giving me truly unique values. I made sure there were no spaces
or hidden characters, and it is repeating the top most value. Here is my
code so far

I had to chenge the range to accomodate my true spreadsheet. and I sorted
this on Desc2 column then ran your code

Sub MakeUniqueList()
Dim rng As Range

Rows("1:1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Sort Key1:=Range("M2"), Order1:=xlAscending, Key2:=Range("D2") _
, Order2:=xlAscending, Header:=xlYes, OrderCustom:=1,
MatchCase:=False _
, Orientation:=xlTopToBottom

Set rng = Range(Cells(2, 13), Cells(2, 13).End(xlDown))
rng.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("L15"),
Unique:=True
End Sub

and it gave me this

CJX
CJX
CS
PJA
RET
SUB

from this info

Desc 2
CJX
CJX
CS
CS
PJA
PJA
RET
RET
SUB

I actually went it and retyped every row to make sure there were not any
other characters.
 
M

michael.beckinsale

Cyberwolf,

This function requires a header therefore it always thinks the 1st row
is the header. Make sure you have a header in the column and use that
row as the 1st row in the range.

Regards

Michael Beckinsale
 
T

Tom Ogilvy

As Michael stated - Advanced filter assumes a header in the first cell.

Sub MakeUniqueList()
Dim rng As Range

Rows("1:1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Sort Key1:=Range("M2"), _
Order1:=xlAscending, Key2:=Range("D2"), _
Order2:=xlAscending, _
Header:=xlYes, OrderCustom:=1,
MatchCase:=False, _
Orientation:=xlTopToBottom

Set rng = Range(Cells(1, 13), Cells(1, 13).End(xlDown))
rng.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("L15"), _
Unique:=True
' remove the copied header
Range("L15").Delete
End Sub
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Macro help 0
Remove Identical words 0
Match style 0
Macro to Select text from a point given to a specific word 2
Remove Quotes within Data Values 0
Remove Quotes within Data Values 1
Insert columns and values programmatically with IF statement 9
Advice on multiple macros, same code just a different column 9

Top