Subtotal for invoices


New Member
Sep 2, 2015
I am creating invoices for doctors’ offices. Each office has its own sheet in the workbook. The invoices have the doctors’ names for that particular office in column A and itemized amounts in column F, with a total in the bottom cell of column F. The sheets are sorted by column A (doctor name), and can have 1-10 doctors or perhaps more. I need to include subtotals per doctor below the total. So column F should have the total in the last cell already, and then skip one cell, add the word “Subtotals”, then begin with the first subtotal. To the left of the subtotal amount, the doctor’s name should appear. If there is only one doctor in the invoice, there should be no subtotal. If the total is $0, there should be no subtotal. The code has to loop through many sheets, starting with the sheet after the one named “Invoice”, to the last sheet.

I would really appreciate some help with this. Thank you so much.

Private Sub CommandButton1_Click()
    filename = "clientBill.csv"
    outSheet = "Split"
    Dim rootDir As String, connectionName As String
    rootDir = "C:\ClientBill"
    connectionName = "TEXT;" + rootDir + "\" + filename
    With Worksheets(outSheet).QueryTables.Add(Connection:=connectionName, Destination:=Worksheets(outSheet).Range("A1"))
        .Name = filename
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlOverwriteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 437
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .Refresh BackgroundQuery:=False
    End With
End Sub

Private Sub CommandButton2_Click()
  Dim LR As Long, i As Long
  Dim ws As Worksheet
  Dim X As Variant
  Dim cell As Range
  Application.ScreenUpdating = False
Set ws = Sheets("Split")
Set WS2 = Sheets("Template")
Set WS3 = Sheets("Invoice")

LR = ws.Range("F" & ws.Rows.Count).End(xlUp).Row

For i = LR To 1 Step -1
    With Range("G" & i)
        If InStr(.Value, ",") = 0 Then
            .Offset(, -1).Value = .Value
            X = Split(.Value, ",")
            .Offset(, -1).Resize(UBound(X) - LBound(X) + 1).Value = Application.Transpose(X)
        End If
    End With

Next i

LR = Range("F" & Rows.Count).End(xlUp).Row

With Range("A1:G" & LR)
    On Error Resume Next
    .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
    On Error GoTo 0
    .Value = .Value
End With
  Sheets("Split").Range("F:G").NumberFormat = "General"
  For Each cell In Sheets("Split").Range("F:F").Cells
    If Len(cell) > Len(WorksheetFunction.Trim(cell)) Then
        cell.Value = WorksheetFunction.Trim(cell)
    End If
  Sheets("Split").Range("F:F").HorizontalAlignment = xlLeft
  Sheets("Split").Columns("A:G").Copy Sheets("Template").Range("B1")
  WS3.Range("A1").PasteSpecial Paste:=xlPasteValues
  WS3.Range("G1").PasteSpecial Paste:=xlPasteValues
  Application.CutCopyMode = False
  Application.ScreenUpdating = True
End Sub

Private Sub CommandButton3_Click()
  Dim LR As Long
  Dim ws As Worksheet
  Dim vcol, i As Integer
  Dim icol As Long
  Dim myarr As Variant
  Dim title As String
  Dim titlerow As Integer

With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .EnableCancelKey = xlErrorHandler
End With

Set ws = Sheets("Invoice")        'CHANGE THE SHEET NAME AS PER YOUR NEED

LR = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row

title = "A1:G1"             'CHANGE THE TITLE ROW AS PER YOUR NEED
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count

ws.Cells(1, icol) = "Unique"

For i = 2 To LR
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
    ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If

myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))


For i = 2 To UBound(myarr)
    ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
    If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
        Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
        Sheets(myarr(i) & "").Move After:=Worksheets(Worksheets.Count)
    End If

ws.Range("A" & titlerow & ":A" & LR).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit

ws.AutoFilterMode = False
With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .EnableCancelKey = xlInterrupt
End With
End Sub

Private Sub CommandButton4_Click()
    Dim StartIndex As Long, EndIndex As Long, i As Long
    Dim ws As Worksheet
    Dim lookupValue As Range, tableArray As Range, seriesOfRows As Range
    Dim intSheet As Integer, intArrayIndex As Integer
    Dim arSheets() As String
    Dim lcol As Long, lrow As Long
    Dim rng As Range, rng1 As Range, cell1 As Range
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .EnableCancelKey = xlErrorHandler
    End With
    StartIndex = Sheets("Invoice").Index + 1
    EndIndex = Sheets.Count
    Set tableArray = Sheets("Client List").Range("A1:C200")
    intArrayIndex = 0

    For intSheet = StartIndex To EndIndex
        Set lookupValue = Sheets(intSheet).Range("A2")
        If Sheets(intSheet).Name <> "Sheet1" Then
            Sheets(intSheet).Rows(1).Range("D1") = Application.WorksheetFunction.VLookup(lookupValue, tableArray, 2, False)
            LastMonth = Format(DateSerial(Year(Date), Month(Date) - 1, 1), "mm-yyyy")
            With Sheets(intSheet).PageSetup.LeftHeaderPicture
                .filename = "S:\Billing\Client billing\LogoDoNotTouch\cpc_302X181.jpg"
                .Height = 70
                .Width = 120
                .Brightness = 0.36
                .ColorType = msoPictureAutomatic
                .Contrast = 0.59
                .CropBottom = 0
                .CropLeft = 0
                .CropRight = 0
                .CropTop = 0
            End With
            With Sheets(intSheet).PageSetup
                .LeftHeader = "&G"
                .CenterHeader = Sheets(intSheet).Range("C1")
                .RightHeader = "Invoice Detail for " & LastMonth
                .RightFooter = "Page &P of &N"
                .LeftFooter = "Printed on &D"
                .LeftMargin = Application.InchesToPoints(0.4)
                .RightMargin = Application.InchesToPoints(0.3)
                .TopMargin = Application.InchesToPoints(1.5)
                .BottomMargin = Application.InchesToPoints(1)
                .HeaderMargin = Application.InchesToPoints(0.5)
                .FooterMargin = Application.InchesToPoints(0.5)
            End With
            With Sheets(intSheet)
                .Range("A2").Value = "Physician"
                .Range("B2").Value = "Accession Number"
                .Range("C2").Value = "Patient Name"
                .Range("D2").Value = "Collection Date"
                .Range("E2").Value = "Procedure (CPT)"
                .Range("F2").Value = "Amount"
                .Columns("D:F").HorizontalAlignment = xlCenter
                .Columns("B").ColumnWidth = 15.67
                .Columns("A").ColumnWidth = 20.22
            End With
            With Sheets(intSheet)
                lrow = .Range("A" & .Rows.Count).End(xlUp).Row
                lcol = Cells(1, 6).Column
                Set rng1 = .Range(.Cells(1, 1), .Cells(lrow, 1))
                For Each cell1 In rng1
                    Set rng = .Range(.Cells(cell1.Row, 1), .Cells(cell1.Row, lcol))
                    With rng
                        With .Borders(xlEdgeBottom)
                            .LineStyle = xlContinuous
                            .Weight = xlThin
                            .ColorIndex = xlAutomatic
                        End With
                    End With
                Next cell1
                With rng
                    With .Borders(xlEdgeBottom)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .ColorIndex = xlAutomatic
                    End With
                End With
                Set rng = .Range(.Cells(1, 1), .Cells(1, lcol))
                   rng.Borders(xlEdgeBottom).LineStyle = xlDouble
                   rng.Font.Bold = True
                   rng.Borders(xlEdgeLeft).LineStyle = xlNone
                   rng.Borders(xlEdgeRight).LineStyle = xlNone
                   rng.Borders(xlInsideHorizontal).LineStyle = xlNone
               .Range("F" & lrow + 1).Value = Application.WorksheetFunction.Sum(.Range("F2:F" & lrow))
               .Columns("F").Style = "Currency"
             End With
            ReDim Preserve arSheets(intArrayIndex)
            arSheets(intArrayIndex) = Sheets(intSheet).Name
            intArrayIndex = intArrayIndex + 1
        End If
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .EnableCancelKey = xlInterrupt
    End With
End Sub

Private Sub CommandButton5_Click()
    Dim StartIndex As Long, EndIndex As Long, i As Long, lrow As Long, llrow As Long, wsname As String
    Dim intSheet As Integer
    StartIndex = Sheets("Invoice").Index + 1
    EndIndex = Sheets.Count
    Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Totals"
    For intSheet = StartIndex To EndIndex
        llrow = Sheets("Totals").Range("B" & Sheets("Totals").Rows.Count).End(xlUp).Row + 1
        wsname = Sheets(intSheet).Name
         If Sheets(intSheet).Name <> "Sheet1" Then
            With Sheets(intSheet)
                lrow = .Range("F" & .Rows.Count).End(xlUp).Row
                .Range("F" & lrow).Copy Sheets("Totals").Range("B" & llrow)
                Sheets("Totals").Range("A" & llrow) = wsname
            End With
        End If
    With Sheets("Totals")
        .Range("A1").Value = "Client"
        .Range("b1").Value = "Total"
    End With
End Sub

Some videos you may like

Excel Facts

Which Excel functions can ignore hidden rows?
The SUBTOTAL and AGGREGATE functions ignore hidden rows. AGGREGATE can also exclude error cells and more.

Watch MrExcel Video

Forum statistics

Latest member