I have VBA to sort vendor names and amount in a spreadsheet. The code sorts alpha and subtotals each account. My question is how do I alter the code so only the subtotals are bold with comma format and a top border?
Private Sub cmdReport_Click()
Dim WSsrc As Worksheet
Dim WSReport As Worksheet
Dim LRSrc As Long
Dim LRrep As Long
Dim LastRow As Long
Dim LastCol As Long
Dim aCol As Long
Dim C As Range
Dim A As Long
Dim Cnt As Long
Dim firstAddress As String
Dim eTotal As Double
'Define worksheet source
Set WSsrc = Worksheets("POMEC")
'Test if there's a selection in the combobox.
If Me.cmbCat.ListIndex > -1 Then
'Add a new worksheet
Set WSReport = Worksheets.Add(before:=Worksheets(1))
With WSReport
'Check sheetname and keep adding 1 until not found.
If SheetExists("Report " & Me.cmbCat) Then
Cnt = 1
Do
If SheetExists("Report " & Me.cmbCat & " - " & Cnt) Then
Cnt = Cnt + 1
Else
.Name = "Report " & Me.cmbCat & " - " & Cnt
Exit Do
End If
Loop
Else
.Name = "Report " & Me.cmbCat
End If
'Headers
With .PageSetup
.Orientation = xlLandscape
.RightHeader = "&LPage &P"
.LeftHeader = "&L" & Date
.CenterHeader = "POMEC Account Transactions"
End With
'Format certain columns
.Columns(1).NumberFormat = "@"
.Columns(2).NumberFormat = "mm/dd/yy"
.Columns(5).NumberFormat = "$#.##"
'Headers
.Range("A1") = "Number"
.Range("B1") = "Date"
.Range("C1") = "Payee"
.Range("D1") = "Category"
.Range("E1") = "Amount"
'Borders
With .Range("A1:E1")
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
End With
.Font.Bold = True
End With
End With
'Last column of source sheet.
LastCol = WSsrc.Cells(3, WSsrc.Columns.Count).End(xlToLeft).Column
If Me.cmbCat.ListIndex = 0 Then
aCol = LastCol - 1
Else
'The column stored in combobox.
aCol = Me.cmbCat.Column(1, Me.cmbCat.ListIndex)
End If
'Starting row number of destination sheet.
LRSrc = 4
For A = 6 To aCol Step 2
With WSsrc
'Last row of source sheet.
LastRow = .Cells(.Rows.Count, A).End(xlUp).Row
'Define search range.
With .Range(.Cells(15, A), .Cells(LastRow, A))
Set C = .Find("*", LookIn:=xlValues)
If Not C Is Nothing Then
'Record starting found address.
firstAddress = C.Address
'Replace the line break with a dash from Column header.
WSReport.Range("A" & LRSrc) = Replace(WSsrc.Cells(3, A), Chr(10), "-")
'Bold
WSReport.Range("A" & LRSrc).Font.Bold = True
LRSrc = LRSrc + 1
Do
'Found. Add to destination sheet.
'Number
WSReport.Cells(LRSrc, 1) = WSsrc.Cells(C.Row, 2)
'Date
WSReport.Cells(LRSrc, 2) = WSsrc.Cells(C.Row, 1)
'Payee
WSReport.Cells(LRSrc, 3) = WSsrc.Cells(C.Row, 3)
'Category
WSReport.Cells(LRSrc, 4) = Replace(WSsrc.Cells(3, A), Chr(10), "-")
'Amount
WSReport.Cells(LRSrc, 5) = Format(Val(C), " ($* #,##0.00 ); ($* (#,##0.00); ($* ""-""?? ); (@_)")
eTotal = eTotal + Val(C)
'Increment Destination row
LRSrc = LRSrc + 1
'Look for another amount in column.
Set C = .FindNext(C)
Loop While Not C Is Nothing And C.Address <> firstAddress
End If
End With
End With
WSReport.Cells(LRSrc, 5) = Format(eTotal, " ($* #,##0.00 ); ($* (#,##0.00); ($* ""-""?? ); (@_)")
eTotal = 0
'Increment Destination category row
LRSrc = LRSrc + 2
Next
'Autofit columns in destination sheet.
WSReport.Range("A4:E" & LRSrc).Columns.AutoFit
End If
WSReport.Range("A:A", "D:D").WrapText = False
Unload Me
End Sub
Private Sub cmdReport_Click()
Dim WSsrc As Worksheet
Dim WSReport As Worksheet
Dim LRSrc As Long
Dim LRrep As Long
Dim LastRow As Long
Dim LastCol As Long
Dim aCol As Long
Dim C As Range
Dim A As Long
Dim Cnt As Long
Dim firstAddress As String
Dim eTotal As Double
'Define worksheet source
Set WSsrc = Worksheets("POMEC")
'Test if there's a selection in the combobox.
If Me.cmbCat.ListIndex > -1 Then
'Add a new worksheet
Set WSReport = Worksheets.Add(before:=Worksheets(1))
With WSReport
'Check sheetname and keep adding 1 until not found.
If SheetExists("Report " & Me.cmbCat) Then
Cnt = 1
Do
If SheetExists("Report " & Me.cmbCat & " - " & Cnt) Then
Cnt = Cnt + 1
Else
.Name = "Report " & Me.cmbCat & " - " & Cnt
Exit Do
End If
Loop
Else
.Name = "Report " & Me.cmbCat
End If
'Headers
With .PageSetup
.Orientation = xlLandscape
.RightHeader = "&LPage &P"
.LeftHeader = "&L" & Date
.CenterHeader = "POMEC Account Transactions"
End With
'Format certain columns
.Columns(1).NumberFormat = "@"
.Columns(2).NumberFormat = "mm/dd/yy"
.Columns(5).NumberFormat = "$#.##"
'Headers
.Range("A1") = "Number"
.Range("B1") = "Date"
.Range("C1") = "Payee"
.Range("D1") = "Category"
.Range("E1") = "Amount"
'Borders
With .Range("A1:E1")
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
End With
.Font.Bold = True
End With
End With
'Last column of source sheet.
LastCol = WSsrc.Cells(3, WSsrc.Columns.Count).End(xlToLeft).Column
If Me.cmbCat.ListIndex = 0 Then
aCol = LastCol - 1
Else
'The column stored in combobox.
aCol = Me.cmbCat.Column(1, Me.cmbCat.ListIndex)
End If
'Starting row number of destination sheet.
LRSrc = 4
For A = 6 To aCol Step 2
With WSsrc
'Last row of source sheet.
LastRow = .Cells(.Rows.Count, A).End(xlUp).Row
'Define search range.
With .Range(.Cells(15, A), .Cells(LastRow, A))
Set C = .Find("*", LookIn:=xlValues)
If Not C Is Nothing Then
'Record starting found address.
firstAddress = C.Address
'Replace the line break with a dash from Column header.
WSReport.Range("A" & LRSrc) = Replace(WSsrc.Cells(3, A), Chr(10), "-")
'Bold
WSReport.Range("A" & LRSrc).Font.Bold = True
LRSrc = LRSrc + 1
Do
'Found. Add to destination sheet.
'Number
WSReport.Cells(LRSrc, 1) = WSsrc.Cells(C.Row, 2)
'Date
WSReport.Cells(LRSrc, 2) = WSsrc.Cells(C.Row, 1)
'Payee
WSReport.Cells(LRSrc, 3) = WSsrc.Cells(C.Row, 3)
'Category
WSReport.Cells(LRSrc, 4) = Replace(WSsrc.Cells(3, A), Chr(10), "-")
'Amount
WSReport.Cells(LRSrc, 5) = Format(Val(C), " ($* #,##0.00 ); ($* (#,##0.00); ($* ""-""?? ); (@_)")
eTotal = eTotal + Val(C)
'Increment Destination row
LRSrc = LRSrc + 1
'Look for another amount in column.
Set C = .FindNext(C)
Loop While Not C Is Nothing And C.Address <> firstAddress
End If
End With
End With
WSReport.Cells(LRSrc, 5) = Format(eTotal, " ($* #,##0.00 ); ($* (#,##0.00); ($* ""-""?? ); (@_)")
eTotal = 0
'Increment Destination category row
LRSrc = LRSrc + 2
Next
'Autofit columns in destination sheet.
WSReport.Range("A4:E" & LRSrc).Columns.AutoFit
End If
WSReport.Range("A:A", "D:D").WrapText = False
Unload Me
End Sub
