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

#### LydiaA

##### New Member
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!

### Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.

#### Peter_SSs

##### MrExcel MVP, Moderator
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
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

##### New Member
Thank you ! This works Great!

#### Peter_SSs

##### MrExcel MVP, Moderator
You're welcome. Thanks for the follow-up.

Replies
5
Views
63
Replies
1
Views
122
Replies
8
Views
105
Replies
0
Views
56
Replies
2
Views
546