VBA to split commissions from one sheet to multiple sheets and summarize by account type

Hey this is my first time posing a question. Up to this point, I have been able to scour the internet for formulas or macros to help me create complex Excel files that automate tasks. This situation is a little more complex and I need some help from someone much smarter than me.

What I'm trying to do is this:
1. Each month I get a commissions payout report from SalesForce and export to Excel. I copy and paste it into an Excel template with the macros.
2. This data lists all of the customers that had salespeople on it and the commissions that they earned in the prior month. There could be anywhere from 1-4 salespeople per account. It is possible that there is no salesperson in the Salesperson 1 field but there are salespeople in the other salespeople fields.
3. Then I would like to run a macro that takes that report data and creates a new tab in Excel for each salesperson. Since there are 4 columns for salespeople, a particular salesperson could be listed in any of those 4 columns and I would need the macro to be able to find a particular salesperson and extract their commissions for each customer no matter which column they were in. If there are multiple salespeople per account, then that customer could appear on each salesperson's report with the corresponding commissions. Our current method is to create a PivotTable, select the salesperson then print. We would then change the PivotTable to select Salesperson 2, 3, and 4 and sum all the data from those 4 pivots to create the final report, but with 40+ salespeople and more getting added in the future, that process is cumbersome. Another way we used to do it was to create a report per salesperson from SalesForce but running 40+ individual reports took too long.
4. After all of the sheets are created for each salesperson, we would like to summarize that data on each of those sheets based on the type of account: Electric or Gas. If we can do this step with step 3 that would be ideal.

The SalesForce report spits out additional columns that are not needed for this task so the file that is attached only has columns for the criteria that I need for the macro. The info in the file is also for examples only. It includes a tab called Ideal Report which shows how we would like to see the report for each salesperson.

Please include comments where you change code so that I can follow it and make changes to variables if I need to. I'm hoping this is possible.

Research:
I was going to post my code from the macro here but my company's firewall is preventing me from doing it. Arg. Anyways, it's in the file.

Functions needed for this code are located in another module in the example file. Those seem to work fine.

After changing the column value to "N" for the range of data, and the criteria column to "7" for Column G, I can't get my headers in row 6 to copy over to each of the new sheets. I'm at a loss on how to get them back.

Any help would be appreciated! Thanks!

This can be done with VBA, but you are limited to a maximum of 4 sales people. To get the maximum flexibility from the data it is best to get it in a normalized format.

I have a routine that helps with this. I took your data and copied into the Source Data sheet in Normlized_Data.xlsb. On the Control Panel I configured it so it would "keep" columns A:F and "normalize" the rest.

Running the macro in this program produced the results in the normalized data tab. I copied this data back to your workbook in a tab called Data 1.

Under most circumstances, the normalized data function produces valid normalized data. However, in this case, you had peoples' names and commission amounts interspersed. So I had to do another adjustment. The data came out with the commission data directly under the person data, do I used a formula to bring the commission up to the same line with the person, and then put a filter in place to identify lines with people on them (a numerical value in Column I). I filtered for true, and copied the data into another table on sheet Data 2.

Sheet Data 2 has the true normalized data and this is the format in which you should be entering data in the future (more on that later).

I built a pivot table from this data and "inserted" a slicer. This is only one way to look at the data. Since the data is normalized, you could build a pivot table filtered by customer and which sales people worked on the account.

The normalized data format on Sheet Data 2 is not that intuitive. What I suggest in this case is to build a User Input from to collect the data for columns A:F and then select sales people and enter the commission. A click of the button on the form will append the record to the database.

All of the two-stepping with getting the data into a normalized format is a one-time shot for legacy data.

Looking at the data, I just came up with another idea. You can establish a table that contains the following information: Account Number, Customer Name, Type of Account (Gas or Electric), Sign Date, and Renewal Year.

Then when it comes time to do data entry, you select a Customer Name from a drop-down list in one column and the type of account in another column and the program will look up the rest of the data, so all you need to do is add the sales person and the commission. You will probably want to have another table for data validation for sales people. Add them as you need them.

Let me know if you would like to pursue this approach. In the meantime, have fun playing with the pivot tables.

there are 4 salesperson fields and any combination of 1-4 people from our 40+ salespeople pool could be in those fields.

Quick question....
According to your upload...is Columns G to N the 4 salespersons fields you are referring to...
Does that remain constant?
Is Tucker Investments LLC as salesperson?
Is row 6...the heading...constant?

Perhaps a bit unorthodox....Works for your initial upload...Perhaps someone else can simplify...
Did not have much time...will revisit the code tomorrow and see if I can simplify...and change formats...

My apologies for not responding sooner. Busy here for a Friday.

Here is the normalization "thing" with documentation. It is useful mostly as a one-time shot for converting legacy data. I recommend copying in your data in place of the raw data and run the macro. Then you can copy the results to a "real" program.

Unfortunately, your data didn't quite fit the mold. So I had to do an additional adjustment.

But I see you have a working version so, good luck!

Herewith updated with correct formats...
Tx for rep...Good luck

Yes, some accounts will show zero dollars for commission and that is ok

I'm not sure if this is the right way to do this but I unsolved this thread because after testing this file with real data, I came across a few errors. First, I realized I needed an extra formatting step to get the data from the report to fit the data for the macro to run. That was easy I thought, so I created a new tab and had formulas on Sheet1 link to the Data tab. The macro threw me an Error 13 mismatch so after erasing the formulas and deleting that other tab, the macro ran without errors. This I can do before inserting the report data into this file so that is not a big issue.

What I'm not sure how to fix is when a customer has multiple accounts with us that gives multiple commissions for multiple account types, they are all listed separately on a salesperson's report. For some reason I can't upload screenshots so I will do my best to describe. If salesperson 1 has 5 gas accounts with customer 1 and 10 electricity accounts with customer 1, each of the gas and electricity accounts and their corresponding commission amounts will be listed separately. Would it be possible to summarize the account type per customer so that it appears as it did in sintek's latest upload (post #11)? So all the gas accounts for customer 1 would only have 1 commission amount, all electricity accounts for customer 1 would have 1 commission amount, etc. There are several more account types.

Also, some salespeople have their headings all messed up and the totals fields are out of place. Others have extra blanks.

I included a few of the salespeople reports after the macro is run as examples. It is better to visualize in my mind.

Would it be possible to fix these errors?

Option Explicit
Public rng As Range
Public ws As Worksheet, sht As Worksheet
Public Item, Val, Header
Public salesperson As String, customer As String
Public SP As Object
Public Tot As Double
Public Hdr As Boolean
Public r As Long, col As Long, rw As Long, lrow As Long, sr As Long, i As Long, diff As Long, ii As Long, _
lr As Long, numrows As Long, nrow As Long
Sub Create_Report()
Application.ScreenUpdating = False
Call Extract_Information
For Each Item In SP
    Hdr = False
    For col = 7 To 14 Step 2
        With Sheet1
            .Activate
            lrow = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
            With .Range("A6:N" & lrow)
                .AutoFilter col, Item
            End With
            numrows = .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
            If numrows > 0 Then
                If numrows = 1 Then
                    sr = .Range("A" & Rows.Count).End(xlUp).Row
                Else
                sr = .Range("A7", .Range("A" & Rows.Count).End(xlUp)).SpecialCells(12).Row
                End If
                lr = .Range("A" & Rows.Count).End(xlUp).Row
                Set rng = Union(.Range("B" & sr & ":F" & lr).SpecialCells(12), .Range(.Cells(sr, col + 1), .Cells(lr, col + 1)))
                If Not WorksheetExists(Item) Then
                    Set ws = Sheets.Add
                    ws.Name = Item
                End If
                With ws
                    If Hdr = False Then
                        .Range("A1") = Item: .Range("A1:E1").MergeCells = True: .Range("A1:E1").HorizontalAlignment = xlCenter
                        .Range("A2") = "Commission Report": .Range("A2:E2").MergeCells = True: .Range("A2:E2").HorizontalAlignment = xlCenter
                        .Range("A3") = Worksheets("Sheet1").Range("H2"): .Range("A3:E3").MergeCells = True: .Range("A3:E3").HorizontalAlignment = xlCenter
                        .Range("A1").Resize(3).Font.Bold = True
                        With .Range("A5").Resize(, 5)
                            .Value = Header
                            .Font.Bold = True
                            .Font.ColorIndex = 55
                            .Borders(xlEdgeBottom).Weight = xlThick
                            .Borders(xlEdgeBottom).ColorIndex = 55
                        End With
                        Hdr = True
                    End If
                    nrow = .Range("A" & Rows.Count).End(xlUp).Row + 1
                    rng.Copy
                    .Range("A" & nrow).PasteSpecial xlPasteAll
                    .Range("A" & nrow).Font.Bold = True
                End With
            End If
            .AutoFilterMode = False
            End With
        Next col
        Call sheetfix
Next Item
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Sub sheetfix()
Set sht = ws
With sht
    .Activate
    Tot = 0: lrow = .Range("A" & Rows.Count).End(xlUp).Row
     .Range("A5:A" & lrow).Font.Bold = True
    With .UsedRange.Rows
        Range(.Cells(5, 1), .Cells(.Count, 1)).AdvancedFilter xlFilterCopy, , .Range("P1"), True
        With .Range("P1").CurrentRegion:  Val = .Value:  .Clear:  End With
    End With
    For i = 2 To UBound(Val)
        .Range("A5:F" & lrow).AutoFilter 1, Val(i, 1)
        numrows = .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
        If numrows = 1 Then
            sr = .Range("A" & Rows.Count).End(xlUp).Row
        Else
            sr = .Range("A6", .Range("A" & Rows.Count).End(xlUp)).SpecialCells(12).Row
        End If
            lr = .Range("A" & Rows.Count).End(xlUp).Row: diff = lr - sr
            If numrows > 1 Then
                .Rows(lr + diff).Insert
                .Range("E" & sr & ":E" & lr).Cut Destination:=.Range("A" & sr + 1)
                For ii = 1 To diff + 1
                    .Range("A" & sr + ii) = Space(5) & .Range("A" & sr + ii)
                Next ii
                .Range("F" & sr & ":F" & lr).Cut Destination:=.Range("E" & sr)
                .Range("B" & sr & ":E" & lr).Cut Destination:=.Range("B" & sr + 1)
                .Rows(lr + diff + 1).Insert
                .Range("A" & lr + diff + 1) = Val(i, 1) & " Total"
                .Range("E" & lr + diff + 1) = Application.Sum(.Range("E" & sr + 1 & ":E" & lr + diff + 1))
                Tot = Tot + .Range("E" & lr + diff + 1).Value
                .Range("A" & lr + diff + 1 & ":E" & lr + diff + 1).Interior.ColorIndex = 24
                .Range("A" & lr + diff + 1 & ":E" & lr + diff + 1).Font.Bold = True
            Else
                .Range("E" & lr).Cut
                .Rows(lr + 1).Insert: .Range("A" & lr + 1) = Space(5) & .Range("A" & lr + 1)
                .Range("F" & lr).Cut Destination:=.Range("E" & lr)
                .Range("B" & lr & ":E" & lr).Cut Destination:=.Range("B" & lr + 1)
                .Rows(lr + 2).Insert
                .Range("A" & lr + 2) = Val(i, 1) & " Total"
                .Range("E" & lr + 2) = Application.Sum(.Range("E" & lr + 1 & ":E" & lr))
                Tot = Tot + .Range("E" & lr + 2).Value
                .Range("A" & lr + 2 & ":E" & lr + 2).Interior.ColorIndex = 24
                .Range("A" & lr + 2 & ":E" & lr + 2).Font.Bold = True
             End If
        Next i
        .AutoFilterMode = False
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("A" & lr + 1) = "Totals": .Range("E" & lr + 1) = Tot
        With .Range("A" & lr + 1 & ":E" & lr + 1)
            .Font.Bold = True
            .Borders(xlEdgeBottom).Weight = xlThick
            .Borders(xlEdgeBottom).ColorIndex = 55
            .Borders(xlEdgeBottom).LineStyle = xlDouble
        End With
        .Columns("E:E").NumberFormat = "0.00"
        .Columns("A:E").Columns.AutoFit
 End With
 
 Call disclaimer
 
 Sheets("Sheet1").Activate
End Sub

Sub Extract_Information()
Header = Array("Customer", "Customer Sign Date", "Start Date", "Renewal", "Commission")
Set SP = CreateObject("System.Collections.ArrayList")
With Sheet1
    lrow = .Range("A" & Rows.Count).End(xlUp).Row
    For col = 7 To 14 Step 2
        For rw = 7 To lrow
           If Not .Cells(rw, col) = "" Then
                salesperson = .Cells(rw, col)
                If Not SP.Contains(salesperson) Then SP.Add salesperson
            End If
        Next rw
    Next col
    SP.Sort
End With
End Sub

Function WorksheetExists(Item) As Boolean
WorksheetExists = Evaluate("ISREF('" & Item & "'!A1)")
End Function


Sub disclaimer()
    Application.ScreenUpdating = False
    Dim ws As Worksheet
    Dim N As Long
    For Each ws In Sheets
        If ws.Name <> "Sheet1" And ws.Name <> "Sheet2" Then
            N = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1
            ws.Cells(N, "A") = "This report is confidential and for use between Company Name and the affinity/referral partner only. It is not to be disclosed to any other third party."
            ws.Activate
            With Cells(N, "A")
                .Font.Size = 10
                .VerticalAlignment = xlTop
                .Resize(2, 5).Merge
                .WrapText = True
                .HorizontalAlignment = xlCenter
            End With
        End If
    Next ws
    Application.ScreenUpdating = True
End Sub

I came across a few errors

Cannot recreate ... need an upload of your actual setup to go through...
The code was written for your thread upload....Any changes to this will render the code null & void...

Also, some salespeople have their headings all messed up and the totals fields are out of place. Others have extra blanks.

Is there any pattern...

I'm doing my best to understand the code but it's been awhile since I had Visual Basic .NET in college

I have it set up so that I can paste my report data into the Data tab and Sheet1 pulls that data and formats it properly. I found a workaround to the tab length restriction of 31 characters. It's not in this file because I changed the salesperson names but for salespeople that have more than 31 characters, it does a vlookup on Sheet2 and replaces it with an abbreviated name. I also added a disclaimer macro to run at the end of the CreateReports macro to insert a short disclaimer at the end of the data on each tab.

I changed the paste command to be PasteValuesAndNumberFormatting which seems to have partially fixed some of the data that was populating the new tabs. The dates are now correctly showing on the salesperson tabs, however, I'm still having trouble with the layout of some of the reports. I'm hoping that by changing the paste command I haven't messed up anything else.

Would you be able to help me figure out why the formatting doesn't work as it did in the original sample file? I tried to have that sample file be similar to the way the actual report looks. I opened the sample file again and made a second ABC Corporation electric account and the formatting came out the same as the report attached to this post.

Anything you can do to help would be greatly appreciated.

Instead of re-inventing the wheel...

Sub sheetfix()
Set sht = ws
With sht
    '.Activate
    Tot = 0: lrow = .Range("A" & Rows.Count).End(xlUp).Row
    .Range("A6:F" & lrow).Sort key1:=.Range("A6"), Order1:=xlAscending
    .Range("A5:A" & lrow).Font.Bold = True
    With .UsedRange.Rows
        Range(.Cells(5, 1), .Cells(.Count, 1)).AdvancedFilter xlFilterCopy, , .Range("P1"), True
        With .Range("P1").CurrentRegion:  Val = .Value:  .Clear:  End With
    End With
    For i = 2 To UBound(Val)
        .Range("A5:F" & lrow).AutoFilter 1, Val(i, 1)
        numrows = .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
        If numrows = 1 Then
            sr = .Range("A" & Rows.Count).End(xlUp).Row
        Else
            sr = .Range("A6", .Range("A" & Rows.Count).End(xlUp)).SpecialCells(12).Row
        End If
            lr = .Range("A" & Rows.Count).End(xlUp).Row: diff = numrows - (lr - sr)
            If numrows > 1 Then
                .Rows(lr + diff).Insert
                .Range("E" & sr & ":E" & lr).Cut Destination:=.Range("A" & sr + 1)
                For ii = 1 To numrows + 1
                    .Range("A" & sr + ii) = Space(5) & .Range("A" & sr + ii)
                Next ii
                .Range("F" & sr & ":F" & lr).Cut Destination:=.Range("E" & sr)
                .Range("B" & sr & ":E" & lr).Cut Destination:=.Range("B" & sr + 1)
                .Rows(lr + diff + 1).Insert
                .Range("A" & lr + diff + 1) = Val(i, 1) & " Total"
                .Range("E" & lr + diff + 1) = Application.Sum(.Range("E" & sr + 1 & ":E" & lr + diff + 1))
                Tot = Tot + .Range("E" & lr + diff + 1).Value
                .Range("A" & lr + diff + 1 & ":E" & lr + diff + 1).Interior.ColorIndex = 24
                .Range("A" & lr + diff + 1 & ":E" & lr + diff + 1).Font.Bold = True
            Else
                .Range("E" & lr).Cut
                .Rows(lr + 1).Insert: .Range("A" & lr + 1) = Space(5) & .Range("A" & lr + 1)
                .Range("F" & lr).Cut Destination:=.Range("E" & lr)
                .Range("B" & lr & ":E" & lr).Cut Destination:=.Range("B" & lr + 1)
                .Rows(lr + 2).Insert
                .Range("A" & lr + 2) = Val(i, 1) & " Total"
                .Range("E" & lr + 2) = Application.Sum(.Range("E" & lr + 1 & ":E" & lr))
                Tot = Tot + .Range("E" & lr + 2).Value
                .Range("A" & lr + 2 & ":E" & lr + 2).Interior.ColorIndex = 24
                .Range("A" & lr + 2 & ":E" & lr + 2).Font.Bold = True
             End If
        Next i
        .AutoFilterMode = False
        lr = .Range("E" & Rows.Count).End(xlUp).Row
        .Range("A" & lr + 1) = "Totals": .Range("E" & lr + 1) = Tot
        With .Range("A" & lr + 1 & ":E" & lr + 1)
            .Font.Bold = True
            .Borders(xlEdgeBottom).Weight = xlThick
            .Borders(xlEdgeBottom).ColorIndex = 55
            .Borders(xlEdgeBottom).LineStyle = xlDouble
        End With
        .Columns("E:E").NumberFormat = "0.00"
        .Columns("A:E").Columns.AutoFit
 End With
End Sub

In future please ... when posting a thread ... Express you entire requirement from the start with actual workbook scenario setup so that we do not waste unnecessary time on coding...Every request becomes more and more advanced and requires major changes to initial code which worked for initial setup...
This should solve...

Sub sheetfix()
Set sht = ws
With sht
    '.Activate
    Tot = 0: lrow = .Range("A" & Rows.Count).End(xlUp).Row
    .Range("A6:F" & lrow).Sort key1:=.Range("A6"), Order1:=xlAscending
    .Range("A5:A" & lrow).Font.Bold = True
    With .UsedRange.Rows
        Range(.Cells(5, 1), .Cells(.Count, 1)).AdvancedFilter xlFilterCopy, , .Range("P1"), True
        With .Range("P1").CurrentRegion:  Val = .Value:  .Clear:  End With
    End With
    With .UsedRange.Rows
        Range(.Cells(5, 5), .Cells(.Count, 5)).AdvancedFilter xlFilterCopy, , .Range("P1"), True
        With .Range("P1").CurrentRegion:  Comm = .Value: .Clear:  End With
    End With
    For i = 2 To UBound(Val)
        .Range("A5:F" & lrow).AutoFilter 1, Val(i, 1)
        For ii = 2 To UBound(Comm)
            .Range("A5:F" & lrow).AutoFilter 5, Comm(ii, 1)
            numrows = .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
            If numrows = 1 Then
                sr = .Range("A" & Rows.Count).End(xlUp).Row
            Else
                sr = .Range("A6", .Range("A" & Rows.Count).End(xlUp)).SpecialCells(12).Row
            End If
            lr = .Range("A" & Rows.Count).End(xlUp).Row
            If numrows > 1 Then
            .Range("F" & sr) = Application.Sum(.Range("F" & sr & ":F" & lr))
            .Range("F" & sr + 1 & ":F" & lr).EntireRow.Delete
            End If
        Next ii
        .Range("A5:F" & lrow).AutoFilter 5
        numrows = .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
        If numrows = 1 Then
            sr = .Range("A" & Rows.Count).End(xlUp).Row
        Else
            sr = .Range("A6", .Range("A" & Rows.Count).End(xlUp)).SpecialCells(12).Row
        End If
            lr = .Range("A" & Rows.Count).End(xlUp).Row: diff = numrows - (lr - sr)
            If numrows > 1 Then
                .Rows(lr + diff).Insert
                .Range("E" & sr & ":E" & lr).Cut Destination:=.Range("A" & sr + 1)
                For ii = 1 To numrows + 1
                    .Range("A" & sr + ii) = Space(5) & .Range("A" & sr + ii)
                Next ii
                .Range("F" & sr & ":F" & lr).Cut Destination:=.Range("E" & sr)
                .Range("B" & sr & ":E" & lr).Cut Destination:=.Range("B" & sr + 1)
                .Rows(lr + diff + 1).Insert
                .Range("A" & lr + diff + 1) = Val(i, 1) & " Total"
                .Range("E" & lr + diff + 1) = Application.Sum(.Range("E" & sr + 1 & ":E" & lr + diff + 1))
                Tot = Tot + .Range("E" & lr + diff + 1).Value
                .Range("A" & lr + diff + 1 & ":E" & lr + diff + 1).Interior.ColorIndex = 24
                .Range("A" & lr + diff + 1 & ":E" & lr + diff + 1).Font.Bold = True
            Else
                .Range("E" & lr).Cut
                .Rows(lr + 1).Insert: .Range("A" & lr + 1) = Space(5) & .Range("A" & lr + 1)
                .Range("F" & lr).Cut Destination:=.Range("E" & lr)
                .Range("B" & lr & ":E" & lr).Cut Destination:=.Range("B" & lr + 1)
                .Rows(lr + 2).Insert
                .Range("A" & lr + 2) = Val(i, 1) & " Total"
                .Range("E" & lr + 2) = Application.Sum(.Range("E" & lr + 1 & ":E" & lr))
                Tot = Tot + .Range("E" & lr + 2).Value
                .Range("A" & lr + 2 & ":E" & lr + 2).Interior.ColorIndex = 24
                .Range("A" & lr + 2 & ":E" & lr + 2).Font.Bold = True
             End If
        Next i
        .AutoFilterMode = False
        lr = .Range("E" & Rows.Count).End(xlUp).Row
        .Range("A" & lr + 1) = "Totals": .Range("E" & lr + 1) = Tot
        With .Range("A" & lr + 1 & ":E" & lr + 1)
            .Font.Bold = True
            .Borders(xlEdgeBottom).Weight = xlThick
            .Borders(xlEdgeBottom).ColorIndex = 55
            .Borders(xlEdgeBottom).LineStyle = xlDouble
        End With
        .Columns("E:E").NumberFormat = "0.00"
        .Columns("A:E").Columns.AutoFit
 End With
Call disclaimer
Sheets("Sheet1").Activate
End Sub

If there are multiple dates for the electric or gas accounts under one customer, would it be possible to return the max value?

What dates are you referring to..Three columns contain dates...

Seems to me the top most dates are always the latest so no need for code there...

...................................
Thanks.gif