Subtotal for invoices

[tharnden]

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 add 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.

Any help would be greatly appreciated. Thank you.

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
Columns("F").Insert


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


Next i


Columns("G").Delete
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
  Next
  Sheets("Split").Range("F:F").HorizontalAlignment = xlLeft
  Sheets("Split").Columns("A:G").Copy Sheets("Template").Range("B1")
  WS2.Columns("B:G").Copy
  WS3.Range("A1").PasteSpecial Paste:=xlPasteValues
  WS2.Columns("J").Copy
  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
    
vcol = 1        'CHANGE THE COLUMN NUMBER AS PER YOUR NEED


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
Next


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


ws.Columns(icol).Clear


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) & ""
    Else
        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
Next


ws.AutoFilterMode = False
Sheets("Split").Activate
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).Insert
            Sheets(intSheet).Rows(1).Range("D1") = Application.WorksheetFunction.VLookup(lookupValue, tableArray, 2, False)
            LastMonth = Format(DateSerial(Year(Date), Month(Date) - 1, 1), "mm-yyyy")
            Sheets(intSheet).Columns("A").Delete
            
            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
            
            Sheets(intSheet).Rows(1).Delete
            
            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
    Next
    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
    Next
    
    With Sheets("Totals")
        .Range("A1").Value = "Client"
        .Range("b1").Value = "Total"
        .Columns("A:B").AutoFit
    End With
End Sub