Sub mather7()
Dim ACCT As Object, SpecAcct As Object, All_Products As Variant, _
Queried_Data As Variant, OB As Variant, T As Long, RTN As ListObject, RR As Range
Set ACCT = CreateObject("Scripting.Dictionary")
With ThisWorkbook
All_Products = .Worksheets("ID").ListObjects("ID").DataBodyRange.Value2 'assumes only 1 column in table
Queried_Data = .Worksheets("ACT").ListObjects("ACT").DataBodyRange.Value2
Set RTN = .Worksheets("RTN").ListObjects("RTN")
End With
'products in B, Accounts in C
With ACCT 'this is a dictionary of Accounts with Account# as key
For X = 1 To UBound(Queried_Data, 1)
If Not .Exists(Queried_Data(X, 3)) And Queried_Data(X, 3) <> "" Then 'if the account doesn't exist
Set SpecAcct = CreateObject("Scripting.Dictionary")
.Add Queried_Data(X, 3), SpecAcct
'key of new dictionary will be Account #
End If
ACCT.Item(Queried_Data(X, 3)).Add Queried_Data(X, 2), Array(Queried_Data(X, 3), Queried_Data(X, 2))
' Account# as key ; product used as key ; array is [account number, product]
Next X
Set SpecAcct = CreateObject("Scripting.Dictionary")
T = 1
End With
For Each OB In ACCT.items ' for each account
With OB
Queried_Data = .keys
For X = 1 To UBound(All_Products, 1)
If Not .Exists(All_Products(X, 1)) And All_Products(X, 1) <> "" Then 'add an array consisting of the accnt # and the missing item
SpecAcct.Add T, Array(.Item(Queried_Data(0))(0), All_Products(X, 1))
'account # , product that wasn't found within dictionary
T = T + 1
End If
Next X
End With
Next OB
With SpecAcct
ReDim Final_A(1 To .Count, 1 To 2)
For T = 1 To .Count 'place into array
For X = 1 To 2
Final_A(T, X) = .Item(T)(X - 1)
Next X
Next T
End With
With RTN 'place on sheet
Set RR = .HeaderRowRange.Find("Account", LookIn:=xlValues, LOOKAT:=xlWhole).Offset(1, 0)
T = RR.Column + 1 - .range.Column
.DataBodyRange.Columns(T).ClearContents
RR.Resize(UBound(Final_A, 1), 1).Value2 = WorksheetFunction.Index(Final_A, 0, 1)
Set RR = .HeaderRowRange.Find("ProductMissing", LookIn:=xlValues, LOOKAT:=xlWhole).Offset(1, 0)
T = RR.Column + 1 - .range.Column
.DataBodyRange.Columns(T).ClearContents
RR.Resize(UBound(Final_A, 1), 1).Value2 = WorksheetFunction.Index(Final_A, 0, 2)
End With
End Sub
