VBA Code / Formula Help Needed to Condense and Subtotal a Table

[nhbartos]

Hi folks,

This may be too complex, but let me know.
I can use some help with some code or macro button and would appreciate it any support.

Here is what I am trying to do:

The "Billing" tab is our exported data, and only a sample is shown. Rows may extend to 1000.

Ideally:
Once data is dropped into the table on the "billing" tab, A6:D1000 I want the macro or code to convert it to what you see in the "Billing Summary" tab. Students may have multiple sessions per day.

1. A date inserted to A:A. The date should be taken from C:D.
2. Columns C:E can be deleted. Student names now in B:B.
3. Session Minutes now in C, Primary CPT Code in D, etc...
4. Make all CPT Codes insert in column D, one below the other, as needed.
5. Make the Billable unit do the same as the CPT codes in column E.
6. Apply subtotal to break by student name, and sum session minutes, and total units.

The date, and the insurance company only need to be shown once, if possible.

Here is a link to my file showing exactly what I am trying to do: Subtotal Test_8-28-17.xlsm - Google Drive

Peace -

Vince

 

[igold]

Hi Vince,


In looking at your file there are some inconsistencies between the Billing tab and the Billing Summary tab. Student 14 is missing, Student 11 is new on the summary and some of the sub totals for other students are not correct.


That said, and assuming these were just simple errors in your example post, then see if this gets you close to where you want to be. I did not code for your different shading of headers and students as there did not seem to be a discernible scheme.


This code will transform your Billing Tab into your Billing Summary tab. If you need to have both you could create a copy of the Billing tab and run the code on that. Please test on a backup copy of your data.

Sub Billing()
    
    Dim opst, npst
    Dim lRow As Long, lrow2 As Long, i As Long, x As Long, s As Long, ct As Long
    Dim dt As String, nam As String
    Dim mins As Single, bu As Single, gtmin As Single, gtbu As Single
    Dim lastrow As Long
    
    Application.ScreenUpdating = False
    dt = Format(Cells(6, 3), "m/dd/yyyy")
    lRow = Cells(Rows.Count, 1).End(xlUp).Row
    ReDim npst(1 To lRow, 1 To 2)
    opst = Range("F6:K" & lRow)
    For i = LBound(opst) To UBound(opst)
        For x = 1 To 6 Step 2
            If opst(i, x) <> "" Then
                npst(i, 1) = opst(i, x)
                npst(i, 2) = opst(i, x + 1)
                Exit For
            End If
        Next
    Next
    Range("F6").Resize(UBound(npst, 1), UBound(npst, 2)) = npst
    gtmin = WorksheetFunction.Sum(Range("E6:E" & lRow))
    gtbu = WorksheetFunction.Sum(Range("G6:G" & lRow))
    With ActiveSheet
        .Range("B:D,H:K").EntireColumn.Delete
        .Range("A1").EntireColumn.Insert
    End With
    
    For s = lRow To 6 Step -1
        nam = Cells(s, 2)
        If nam <> Cells(s - 1, 2) Then
            lrow2 = Cells(Rows.Count, 2).End(xlUp).Row
            Cells(s, 1).Value = dt
            ct = WorksheetFunction.CountIf(Range("B6:B" & lRow), nam) - 1
            Cells(s + ct, 2).Offset(1, 0).EntireRow.Insert shift:=xlDown
            With Cells(s + ct + 1, 2)
                .Value = nam & " Total"
                .Font.Bold = True
            End With
        End If
    Next
    Cells(5, 1).Value = "Date"
    
    Columns("A:F").EntireColumn.AutoFit
    Call GetSubs
    lastrow = Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row
    Cells(lastrow, 2).Value = "Grand Total"
    Cells(lastrow, 3).Value = gtmin
    Cells(lastrow, 5).Value = gtbu
    Application.ScreenUpdating = True
    
End Sub
Sub GetSubs()


    Application.ScreenUpdating = False
    Dim mins As Single, bu As Single
    Dim break As Long
    Dim lastrow As Long


    lastrow = Cells(Rows.Count, "C").End(xlUp).Row
nxt:
    break = Cells(lastrow, "C").End(xlUp).Row
    If Cells(lastrow - 1, 4) = "" Then break = lastrow
    mins = WorksheetFunction.Sum(Range("C" & break, "C" & lastrow))
    bu = WorksheetFunction.Sum(Range("E" & break, "E" & lastrow))
    Range("C" & lastrow).Offset(1, 0).Value = mins
    Range("E" & lastrow).Offset(1, 0).Value = bu
    lastrow = Cells(break, 4).End(xlUp).Row
    If lastrow < 6 Then
        Application.ScreenUpdating = True
        GoTo done
    End If
    GoTo nxt
    Application.ScreenUpdating = True
done:
End Sub

I hope this helps...