Combine each sales rep individually

G

greekexcel

New Member
Joined
Oct 31, 2022
Messages
32
Office Version
  1. 2019
Platform
  1. Windows
I have a table which look like this.

I want excel to understand each "SALES REP" as person.
For example to calculate all sales by KEVIN including the one with collaboration with other sales rep (KEVIN&JOHN) and split the Commission in half or 1/3 depending the situation
Also every time that i input 2 names in the same cell to can excel recognize them as individuals.

Thank you




demo.png
 
Sort by date Sort by votes
I wrote this one really in an hurry. Most probably It won't work :) Please send sample data to work on it (not as an image)
VBA Code: 
Sub test()

    Dim repNames() As String
    Dim tempNames() As String
    
    Dim lRow As Integer
    lRow = Cells(Rows.Count, 6).End(xlUp).Row
    Dim ii As Integer
    
    ii = 0
 
    For i = 1 To lRow
      If InStr(Cells(i, 6).Value, "&") > 0 Then
        tempNames = Split(Cells(i, 6).Value, "&")
        For Each tempName In tempNames
          repNames(ii) = Trim(tempName)
          ii = ii + 1
        Next
      Else
        repNames(ii) = Cells(i, 6).Value
        ii = ii + 1
      End If
    Next
 
    For i = ii - 1 To 0 Step -1
      For iii = i To 1 Step -1
        If repNames(i) = repNames(iii) Then
        repNames(i) = ""
        End If
      Next
    Next
 
    For i = 0 To ii - 1
      If repNames(i) <> "" Then
        Cells(i + 1, 8).Value = repNames(i)
      End If
    Next
 
    iii = Cells(Rows.Count, 8).End(xlUp).Row
    For i = 1 To iii
      For ii = 1 To lRow
        If InStr(Cells(ii, 6).Value, Cells(i, 8).Value) > 0 Then
          If InStr(Cells(ii, 6).Value, "&") > 0 Then
            Cells(i, 9).Value = Cells(i, 9).Value + (Cells(ii, 6).Value / ((Len(Cells(ii, 6).Value) - Len(Replace(Cells(ii, 6).Value, "&", ""))) + 1))
          Else
            Cells(i, 9).Value = Cells(i, 9).Value + Cells(ii, 6).Value
          End If
        End If
      Next
    Next
 
End Sub
 
Last edited by a moderator:
Upvote 0
Fully functional version ;) Enjoy!
VBA Code: 
Sub salesCom()

    Dim repNames() As String
    Dim tempNames() As String
    Dim lRow As Integer
    lRow = Cells(Rows.Count, 6).End(xlUp).Row
    Dim ii As Integer
 
    ii = 0
    For i = 1 To lRow
      tempNames = Split(Cells(i, 6).Value, "&")
      For Each tempName In tempNames
        ReDim Preserve repNames(ii)
        repNames(ii) = Trim(tempName)
        ii = ii + 1
      Next
    Next
 
    For i = ii - 1 To 1 Step -1
      If repNames(i) <> "" Then
        For iii = i - 1 To 0 Step -1
          If repNames(i) = repNames(iii) Then
            repNames(i) = ""
          End If
        Next
      End If
    Next

    iii = 1
    For i = 0 To ii - 1
      If repNames(i) <> "" Then
        Cells(iii, 8).Value = repNames(i)
        iii = iii + 1
      End If
    Next
 
    iii = Cells(Rows.Count, 8).End(xlUp).Row
    For i = 1 To iii
      For ii = 1 To lRow
        If InStr(Cells(ii, 6).Value, Cells(i, 8).Value) > 0 Then
          If InStr(Cells(ii, 6).Value, "&") > 0 Then
            Cells(i, 9).Value = Cells(i, 9).Value + (Cells(ii, 5).Value / ((Len(Cells(ii, 6).Value) - Len(Replace(Cells(ii, 6).Value, "&", ""))) + 1))
          Else
            Cells(i, 9).Value = Cells(i, 9).Value + Cells(ii, 5).Value
          End If
        End If
      Next
    Next
 
End Sub
 
Last edited by a moderator:
Upvote 0
Solution
Flashbond said:
I wrote this one really really quickly. Most probably It won't work :) Please send sample data to work on it (not as an image)
VBA Code: 
Sub test()

    Dim repNames() As String
    Dim tempNames() As String
    Dim nameVar As Boolean
    Dim lRow As Integer
    lRow = Cells(Rows.Count, 6).End(xlUp).Row
    Dim ii As Integer
    nameVar = False
    ii = 0
  
    For i = 1 To lRow
      If InStr(Cells(i, 6).Value, "&") > 0 Then
        tempNames = Split(Cells(i, 6).Value, "&")
        For Each tempName In tempNames
          repNames(ii) = Trim(tempName)
          ii = ii + 1
        Next
      Else
        repNames(ii) = Cells(i, 6).Value
        ii = ii + 1
      End If
    Next
  
    For i = ii - 1 To 0 Step -1
      For iii = i To 1 Step -1
        If repNames(i) = repNames(iii) Then
        repNames(i) = ""
        End If
      Next
    Next
  
    For i = 0 To ii - 1
      If repNames(i) <> "" Then
        Cells(i + 1, 8).Value = repNames(i)
      End If
    Next
  
    iii = Cells(Rows.Count, 8).End(xlUp).Row
    For i = 1 To iii
      For ii = 1 To lRow
        If InStr(Cells(ii, 6).Value, Cells(i, 8).Value) > 0 Then
          If InStr(Cells(ii, 6).Value, "&") > 0 Then
          Cells(i, 9).Value = Cells(i, 9).Value + (Cells(ii, 6).Value / ((Len(Cells(ii, 6).Value) - Len(Replace(Cells(ii, 6).Value, "&", ""))) + 1))
          Else
            Cells(i, 9).Value = Cells(i, 9).Value + Cells(ii, 6).Value
          End If
        End If
      Next
    Next
  
End Sub
Click to expand...
Flashbond said:
I wrote this one really in an hurry. Most probably It won't work :) Please send sample data to work on it (not as an image)
VBA Code: 
Sub test()

    Dim repNames() As String
    Dim tempNames() As String
  
    Dim lRow As Integer
    lRow = Cells(Rows.Count, 6).End(xlUp).Row
    Dim ii As Integer
  
    ii = 0
 
    For i = 1 To lRow
      If InStr(Cells(i, 6).Value, "&") > 0 Then
        tempNames = Split(Cells(i, 6).Value, "&")
        For Each tempName In tempNames
          repNames(ii) = Trim(tempName)
          ii = ii + 1
        Next
      Else
        repNames(ii) = Cells(i, 6).Value
        ii = ii + 1
      End If
    Next
 
    For i = ii - 1 To 0 Step -1
      For iii = i To 1 Step -1
        If repNames(i) = repNames(iii) Then
        repNames(i) = ""
        End If
      Next
    Next
[QUOTE="Flashbond, post: 5969705, member: 143009"]
I wrote this one really in an hurry. Most probably It won't work :) Please send sample data to work on it (not as an image)
[CODE=vba]Sub test()

    Dim repNames() As String
    Dim tempNames() As String
  
    Dim lRow As Integer
    lRow = Cells(Rows.Count, 6).End(xlUp).Row
    Dim ii As Integer
  
    ii = 0
 
    For i = 1 To lRow
      If InStr(Cells(i, 6).Value, "&") > 0 Then
        tempNames = Split(Cells(i, 6).Value, "&")
        For Each tempName In tempNames
          repNames(ii) = Trim(tempName)
          ii = ii + 1
        Next
      Else
        repNames(ii) = Cells(i, 6).Value
        ii = ii + 1
      End If
    Next
 
    For i = ii - 1 To 0 Step -1
      For iii = i To 1 Step -1
        If repNames(i) = repNames(iii) Then
        repNames(i) = ""
        End If
      Next
    Next
 
    For i = 0 To ii - 1
      If repNames(i) <> "" Then
        Cells(i + 1, 8).Value = repNames(i)
      End If
    Next
 
    iii = Cells(Rows.Count, 8).End(xlUp).Row
    For i = 1 To iii
      For ii = 1 To lRow
        If InStr(Cells(ii, 6).Value, Cells(i, 8).Value) > 0 Then
          If InStr(Cells(ii, 6).Value, "&") > 0 Then
            Cells(i, 9).Value = Cells(i, 9).Value + (Cells(ii, 6).Value / ((Len(Cells(ii, 6).Value) - Len(Replace(Cells(ii, 6).Value, "&", ""))) + 1))
          Else
            Cells(i, 9).Value = Cells(i, 9).Value + Cells(ii, 6).Value
          End If
        End If
      Next
    Next
 
End Sub
Click to expand...


For i = 0 To ii - 1
If repNames(i) <> "" Then
Cells(i + 1, 8).Value = repNames(i)
End If
Next

iii = Cells(Rows.Count, 8).End(xlUp).Row
For i = 1 To iii
For ii = 1 To lRow
If InStr(Cells(ii, 6).Value, Cells(i, 8).Value) > 0 Then
If InStr(Cells(ii, 6).Value, "&") > 0 Then
Cells(i, 9).Value = Cells(i, 9).Value + (Cells(ii, 6).Value / ((Len(Cells(ii, 6).Value) - Len(Replace(Cells(ii, 6).Value, "&", ""))) + 1))
Else
Cells(i, 9).Value = Cells(i, 9).Value + Cells(ii, 6).Value
End If
End If
Next
Next

End Sub[/CODE]
[/QUOTE]
Flashbond said:
Fully functional version ;) Enjoy!
VBA Code: 
Sub salesCom()

    Dim repNames() As String
    Dim tempNames() As String
    Dim lRow As Integer
    lRow = Cells(Rows.Count, 6).End(xlUp).Row
    Dim ii As Integer
 
    ii = 0
    For i = 1 To lRow
      tempNames = Split(Cells(i, 6).Value, "&")
      For Each tempName In tempNames
        ReDim Preserve repNames(ii)
        repNames(ii) = Trim(tempName)
        ii = ii + 1
      Next
    Next
 
    For i = ii - 1 To 1 Step -1
      If repNames(i) <> "" Then
        For iii = i - 1 To 0 Step -1
          If repNames(i) = repNames(iii) Then
            repNames(i) = ""
          End If
        Next
      End If
    Next

    iii = 1
    For i = 0 To ii - 1
      If repNames(i) <> "" Then
        Cells(iii, 8).Value = repNames(i)
        iii = iii + 1
      End If
    Next
 
    iii = Cells(Rows.Count, 8).End(xlUp).Row
    For i = 1 To iii
      For ii = 1 To lRow
        If InStr(Cells(ii, 6).Value, Cells(i, 8).Value) > 0 Then
          If InStr(Cells(ii, 6).Value, "&") > 0 Then
            Cells(i, 9).Value = Cells(i, 9).Value + (Cells(ii, 5).Value / ((Len(Cells(ii, 6).Value) - Len(Replace(Cells(ii, 6).Value, "&", ""))) + 1))
          Else
            Cells(i, 9).Value = Cells(i, 9).Value + Cells(ii, 5).Value
          End If
        End If
      Next
    Next
 
End Sub
Click to expand...
First of all thank you very much you are a life saver :)
I was trying to find a solution for this for the past week.
I have another issue as well i will post it later with an attached file as well.
Thank you again!
 
Upvote 0
Hello again! I am a beginner in VBA and i still have some issues and i was wondering if u can help me.
So the issues are:

When you add another row macro should recognize and update outcome
When you change(update) a name in a cell macro should recognize and update outcome

Also i want to count the sales individually to give you an example:
When a sales rep closes a deal i want to count that as 1 point
and if they closed a deal in collaboration with another sales rep each sales rep will split the point accordingly,
if they are two sales rep 0,5 points each
if they are 3 0,33 each

Thank u in advance.

Ps: If u have a video or any links to suggest for developing my vba skills feel free to share.
 
Upvote 0
You should dig around internet for tutorials. I don't know a specific good source for that. However, I took notes next to lines for better understanding. By the way, I am not the best coder. So it doesn't necessarily mean that every code that I write is the most correct thing :)
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range) 'Calculate in every worksheet change
  If (Not Intersect(Target, Range("E:E")) Is Nothing And Target.Offset(0, 1) <> "") Or (Not Intersect(Target, Range("F:F")) Is Nothing And Target.Offset(0, -1) <> "") Then
    'If change has been made in Column E or F and adjancent cell has a value.
    Dim repNames() As String
    Dim tempNames() As String
    Dim lRow As Integer
    lRow = Cells(Rows.Count, 6).End(xlUp).Row 'Get the last row for Reps
    Dim ii As Integer
    Dim iii As Integer
    Range("H2:J" & Cells(Rows.Count, 10).End(xlUp).Row).Clear 'Clear previous calculations

    ii = 0
    For i = 2 To lRow
      tempNames = Split(Cells(i, 6).Value, "&") 'Fetch each rep row to a temporary array
      For Each tempName In tempNames
        ReDim Preserve repNames(ii)
        repNames(ii) = Trim(tempName) 'Insert each rep in main array from temporary array
        ii = ii + 1
      Next
    Next
    'Clear dublicate names
    For i = ii - 1 To 1 Step -1
      If repNames(i) <> "" Then
        For iii = i - 1 To 0 Step -1
          If repNames(i) = repNames(iii) Then 'Clear rep name if found in other position of array
            repNames(i) = ""
          End If
        Next
      End If
    Next

    iii = 2
    For i = 0 To ii - 1
      If repNames(i) <> "" Then 'Write each rep name to cell if the name is not empty.
        Cells(iii, 8).Value = repNames(i)
        iii = iii + 1
      End If
    Next
 
    For i = 2 To iii - 1 'For each unique rep name in Column H
      For ii = 2 To lRow 'For each comm. and rep in column E&F
        If InStr(Cells(ii, 6).Value, Cells(i, 8).Value) > 0 Then 'If Column F contains rep name in Column H
          'Divide commission amount to number of "&" sign+1 and add to previous cell value
          Cells(i, 9).Value = Cells(i, 9).Value + (Cells(ii, 5).Value / ((Len(Cells(ii, 6).Value) - Len(Replace(Cells(ii, 6).Value, "&", ""))) + 1))
          'Add score to column J with same logic instead of using comm. value, using 1.
          Cells(i, 10).Value = Cells(i, 10).Value + (1 / ((Len(Cells(ii, 6).Value) - Len(Replace(Cells(ii, 6).Value, "&", ""))) + 1))
        End If
      Next
    Next
  End If
End Sub
 
Last edited by a moderator:
Upvote 0
Some bugs fixed :)
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range) 'Calculate in every worksheet change
  If (Not Intersect(Target, Range("E:E")) Is Nothing And Target.Offset(0, 1).Value <> "") Or (Not Intersect(Target, Range("F:F")) Is Nothing And Target.Offset(0, -1).Value <> "") Then
    'If change has been made in Column E or F and adjancent cell has a value.
    Application.EnableEvents = False 'Stop listening change events for now
    Dim repNames() As String
    Dim tempNames() As String
    Dim lRow As Integer
    lRow = Cells(Rows.Count, 6).End(xlUp).Row 'Get the last row for Reps
    Dim ii As Integer
    Dim iii As Integer
   
    Range("H2:J" & Cells(Rows.Count, 10).End(xlUp).Row).Clear 'Clear previous calculation
    ii = 0
    For i = 2 To lRow
      tempNames = Split(Cells(i, 6).Value, "&") 'Fetch each rep row to a temporary array
      For Each tempName In tempNames
        ReDim Preserve repNames(ii)
        repNames(ii) = Trim(tempName) 'Insert each rep in main array from temporary array
        ii = ii + 1
      Next
    Next
    'Clear dublicate names
    For i = ii - 1 To 1 Step -1
      If repNames(i) <> "" Then
        For iii = i - 1 To 0 Step -1
          If repNames(i) = repNames(iii) Then 'Clear rep name if found in other position of array
            repNames(i) = ""
          End If
        Next
      End If
    Next
    iii = 2
    For i = 0 To ii - 1
      If repNames(i) <> "" Then 'Write each rep name to cell if the name is not empty.
        Cells(iii, 8).Value = repNames(i)
        iii = iii + 1
      End If
    Next
 
    For i = 2 To iii - 1 'For each unique rep name in Column H
      For ii = 2 To lRow 'For each comm. and rep in column E&F
        If InStr(Cells(ii, 6).Value, Cells(i, 8).Value) > 0 Then 'If Column F contains rep name in Column H
          'Divide commission amount to number of "&" sign+1 and add to previous cell value
          Cells(i, 9).Value = Cells(i, 9).Value + (Cells(ii, 5).Value / ((Len(Cells(ii, 6).Value) - Len(Replace(Cells(ii, 6).Value, "&", ""))) + 1))
          'Add score to column J with same logic instead of using comm. value, using 1.
          Cells(i, 10).Value = Cells(i, 10).Value + (1 / ((Len(Cells(ii, 6).Value) - Len(Replace(Cells(ii, 6).Value, "&", ""))) + 1))
        End If
      Next
    Next
    Application.EnableEvents = True 'Start to listen changes again
  End If
End Sub
 
Last edited by a moderator:
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Question Question
Duplicate a Sales Engineer to an outside Sales Rep
3 4 5
Replies
40
Views
552
Holger
H
J
  • Question Question
Commission Sheet auto load into commission log
Replies
3
Views
396
Rijnsent
Rijnsent
G
  • Solved
Splitting Commission IF
2 3
Replies
27
Views
2K
Peter_SSs
Peter_SSs
M
  • Question Question
Can excel return results that are calculated from separate items in a drop down list
2 3 4
Replies
33
Views
1K
Peter_SSs
Peter_SSs
G
  • Solved
Split commission
2 3
Replies
20
Views
1K
Sufiyan97
Sufiyan97

Share this page

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