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

[LydiaA]

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​
Date	Credited Month	Customer name	Product	Banker
10/02/20	October	Smith	aaa	Dave
10/10/20	October	Smith	bbb	Sally
09/10/20	September	Williams	aaa	Mark
11/02/20	October	Smith	ccc	Dave
11/08/20	November	James	aaa	Sally
11/08/20	November	James	bbb	Sally

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!

 

[Peter_SSs]

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.

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

 

[LydiaA]

Thank you ! This works Great!

 

[Peter_SSs]

You're welcome. Thanks for the follow-up.