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

nhbartos

Board Regular
Joined
May 23, 2015
Messages
148
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
 

Excel Facts

Back into an answer in Excel
Use Data, What-If Analysis, Goal Seek to find the correct input cell value to reach a desired result
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.

Code:
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...
 
Upvote 0

Forum statistics

Threads
1,213,494
Messages
6,113,974
Members
448,537
Latest member
Et_Cetera

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top