How to write a VBA code to Count total number of distinct values that meet multiple criteria in Excel

LydiaA

New Member
Joined
Nov 13, 2020
Messages
3
Office Version
  1. 2010
Platform
  1. Windows
I have been using a combination of Pivot Tables and IF logic statements to determine customer cross-sell however with 10's of thousands of rows of data Excel either stops responding or my computer shuts off completely due to the massive amount of processing capacity needed to execute these functions. I am hoping a VBA code could perform the same calculation an solve for the processing issues.

Objective: Calculate total number of distinct customers and bankers to determine product cross-sell. Cross-sell is only applied when the SAME Banker sells multiple products to the SAME Customer. If the second product is sold in a later month the cross sell is credited to the month of the first sale. See below example....

A​
B​
C​
D​
E​
DateCredited MonthCustomer nameProductBanker
10/02/20OctoberSmithaaaDave
10/10/20OctoberSmithbbbSally
09/10/20SeptemberWilliamsaaaMark
11/02/20OctoberSmithcccDave
11/08/20NovemberJamesaaaSally
11/08/20NovemberJamesbbbSally

I would like the VBA code to return a summary of the total # of customers that were cross-sold by month (according to the above criteria)

For the data above it would return this...

Summary by Months
September
October
November
Total Customers
1​
2​
1​
Cross-Sell Customers
0​
1​
1​
% Cross Sell
0%​
50%​
100%​


Explanation:
  • In Sep Mark made 1 sale to 1 customer = 1 customer with no cross sell
  • in Oct Dave made only 1 sale to Smith but another to Smith in Nov (since cross is credited to the month of the first sale by the same banker = 1 cross sell counts for Oct. Sally also sold to Smith but only 1 product = no cross sell so Smith counts as two customers (1 single sale customer and 1 cross sell customer for the month of Oct)
  • In Nov Sally sold 2 products to the same customer = 1 cross sell for Nov
Is there a way to achieve these results with VBA code versus the pivot table\formulaic acrobatics I have to do to achieve this without coding? I understand multiple VBA codes may be necessary to calculate the cross-sell and to assign the "credited month" (which is equal to the month of the 1st sale when the same banker sells multiple products to the same customer across several months)

thank you so much!
 

Some videos you may like

Excel Facts

What do {} around a formula in the formula bar mean?
{Formula} means the formula was entered using Ctrl+Shift+Enter signifying an old-style array formula.

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
47,515
Office Version
  1. 365
Platform
  1. Windows
Welcome to the MrExcel board!

Try this with a copy of your workbook after saving any open workbooks. Results are returned in columns G, H, I, ..

I have assumed that all dates are in the same calendar year since your sample result headings are month names with no year.

VBA Code:
Sub CrossSell()
  Dim d As Object, fm As Object
  Dim a As Variant, b As Variant, Bits As Variant
  Dim i As Long, Cust As Long, XCust As Long
  Dim s As String, t As String, u As String, sMnth As String
  
  Set d = CreateObject("Scripting.Dictionary")
  d.CompareMode = 1
  Set fm = CreateObject("Scripting.Dictionary")
  fm.CompareMode = 1
  With Range("A2", Range("E" & Rows.Count).End(xlUp))
    b = .Value
    .Sort Key1:=.Columns(1), Order1:=xlAscending, Header:=xlNo
    a = .Value
    .Value = b
  End With
  For i = 1 To UBound(a)
    s = a(i, 5) & "|" & a(i, 3)
    t = "#^" & s & "@" & a(i, 4) & "^#"
    sMnth = Format(a(i, 1), "mmmm")
    If fm.exists(s) Then
      sMnth = fm(s)
    Else
      fm(s) = sMnth
    End If
    If d.exists(sMnth) Then
      If InStr(1, d(sMnth), t, 1) = 0 Then
        d(sMnth) = d(sMnth) & t
      End If
    Else
      d(sMnth) = t
    End If
  Next i
  ReDim b(1 To 3, 1 To d.Count)
  For i = 1 To d.Count
    u = d.Items()(i - 1)
    Cust = 0: XCust = 0
    Do Until Len(u) = 1
      s = Mid(Left(u, InStr(1, u, "@")), 2)
      Bits = Split(u, "##")
      Cust = Cust + 1
      If UBound(Filter(Bits, s)) > 0 Then XCust = XCust + 1
      u = "#" & Join(Filter(Bits, s, False), "##")
    Loop
    b(1, i) = Cust
    b(2, i) = XCust
    b(3, i) = XCust / Cust
  Next i
  With Range("H2").Resize(UBound(b, 1), UBound(b, 2))
    .Value = b
    .Rows(UBound(b)).NumberFormat = "0.0%"
    .Rows(0).Value = d.Keys
    .Columns(0).Value = Application.Transpose(Array("Total Customers", "Cross-Sell Customers", "% Cross Sell"))
    .CurrentRegion.Columns.AutoFit
  End With
End Sub
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
47,515
Office Version
  1. 365
Platform
  1. Windows
You're welcome. Thanks for the follow-up. :)
 

Watch MrExcel Video

Forum statistics

Threads
1,119,094
Messages
5,576,078
Members
412,697
Latest member
ahem27
Top