Optimizing VBA for Speed

[Veritan]

Hello all. I am trying to speed up some code that I have written. What I have works perfectly fine, but is quite slow. I would like to see if there is a way to increase the speed.

My workbook consists of 3 sheets. The first tab (named "Access Data") contains a table (named "tblData") with 5 fields. The headers in sequential order are "User", "Dept", "Module", "Header", and "Job Name". The 2 relevant fields are the "User" and "Job Name" fields. The "User" field contains a series of user names. The "Job Name" field contains all the different jobs that they are able to perform. The table is sorted first by "User", then by "Job Name", both in ascending order. Each User can have multiple jobs, but a given job can only appear once for a specific user. However, a given job may appear for more than 1 user.

The 2nd sheet (named "SOD Testing") is just a repository for the results of the code execution. Cell B1 contains a simple title string ("List of Duties/Jobs"). Cell B2 contains the formula

=SORT(UNIQUE(tblData[Job Name]))

Cell C1 contains the formula

=TRANSPOSE(SORT(UNIQUE(tblData[Job Name])))

This results in sorted lists of the unique Job Names. The rest of this sheet is filled out by VBA.

The 3rd sheet (named "SOD Notifications") is used to hold a list of the users and the jobs that they perform. However, only certain users and jobs qualify to be on this list (I'll explain more later). Range A1:C1 contains some simple headers ("User", "Job Name 1", "Job Name 2") and the rest of the sheet is blank, but is filled out by VBA.

My goal is 2-fold. First, based on the grid established on "SOD Testing", I want to know how many users are able to do each job listed there. For example, if cell B4 contains "Checks and Registers" and cell E1 contains "Manual Checks", then cell E4 should contain the number of users who are able to do both "Checks and Registers" and "Manual Checks". If there are 3 users that are able to do both jobs, then cell E4 should contain the number 3. Second, certain jobs are not allowed to be performed by the same user. On the "SOD Testing" sheet, the intersecting cell of these jobs is highlighted in red. For example, if cell B10 contains "Void Checks" and cell F1 contains "Prepare Check Proofing" and these two jobs are not allowed to be performed by the same user, then cell F10 would be highlighted in red. This is done manually and is done before running any code.

If my code detects that there is a conflict (in other words, if it identifies that the same user is allowed to perform two conflicting jobs), then it lists the User and both Job Names on the "SOD Notifications" tab starting in cell A2.

Currently, my tblData contains almost 2,000 records, and there are almost 300 unique Job Names. This is a smaller sampling size, and will get larger when we use this for other scenarios. As a result, I'm hoping to find a way to run this code quickly. I have come up with 2 different solutions. Both of these work perfectly. However, they are both fairly slow. In order to speed up the process, I am hoping that somebody can provide some insight into speeding this up. Thank you very much for any and all assistance!

Edit: I'm reasonably comfortable with Power Query and Power Pivot, so solutions involving them are perfectly fine as well.

Note: Both code segments are called while the "SOD Testing" sheet is the active sheet.

Version 1 (no arrays)

Sub Check_Duties()
    Dim wsData As Worksheet, strFirstAddress As String
    Dim r As Range, strJob As String, rngJob As Range, strUser As String, intOccurrences As Integer
    Dim intTotal As Integer, wsNotifications As Worksheet, rngDuties As Range, msgContinue As VbMsgBoxResult
    Dim loData As ListObject, lngFoundRow As Long
   
    msgContinue = MsgBox(Prompt:="CAUTION!! This process can take several minutes to complete. " & _
                                 "During this time, you will not be able to use Excel. " & _
                                 "Are you sure you wish to continue?", _
                         Buttons:=vbYesNo + vbExclamation + vbDefaultButton2, _
                         Title:="Extended Processing Time Required")
    If msgContinue = vbNo Then Exit Sub
                   
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
   
    'Set the major variables that will be used throughout the code
    Set wsData = Sheets("Access Data")
    Set wsNotifications = Sheets("SOD Notifications")
    Set loData = wsData.ListObjects(1)
    Set rngDuties = Range(Cells(2, "C"), Cells(Cells(Rows.Count, "B").End(xlUp).Row, Cells(1, Columns.Count).End(xlToLeft).Column))
   
    'Clear any existing data to start fresh. Note that cell fill colors are intentionally left intact.
    wsNotifications.Range("A2:C" & wsNotifications.Cells(Rows.Count, "A").End(xlUp).Offset(1).Row).ClearContents
    rngDuties.ClearContents
   
    For Each r In rngDuties
        'Make sure that the row and column values are different.
        If Cells(r.Row, "B") <> Cells(1, r.Column) Then
            strJob = Cells(r.Row, "B")
            Set rngJob = loData.ListColumns("Job Name").DataBodyRange.Find(What:=strJob, LookAt:=xlWhole)
            If Not rngJob Is Nothing Then
                lngFoundRow = loData.ListRows(rngJob.Row - loData.HeaderRowRange.Row).Index
                'Set the exit condition for the Do loop.
                strFirstAddress = rngJob.Address
                'Reset the count of users.
                intTotal = 0
                Do
                    intOccurrences = 0
                    strUser = loData.ListColumns("User").DataBodyRange(lngFoundRow)
                    'Find out if there are any occurrences where the given user has the Job Name that is presented in Row 1 on the active sheet.
                    intOccurrences = WorksheetFunction.CountIfs(loData.ListColumns("User").DataBodyRange, strUser, loData.ListColumns("Job Name").DataBodyRange, Cells(1, r.Column))
                    'If there are any undesired combinations of duties, highlighting the cell in red will cause the SOD Notifications tab to _
                     display the user and their conflict of duties.
                    If r.Interior.Color = vbRed And intOccurrences > 0 Then
                        With wsNotifications
                            .Cells(Rows.Count, "A").End(xlUp).Offset(1) = strUser
                            .Cells(Rows.Count, "B").End(xlUp).Offset(1) = strJob
                            .Cells(Rows.Count, "C").End(xlUp).Offset(1) = Cells(1, r.Column)
                        End With
                    End If
                    'Track the total number of users with the given Job Name combination.
                    intTotal = intTotal + intOccurrences
                    Set rngJob = loData.ListColumns("Job Name").DataBodyRange.FindNext(rngJob)
                Loop Until rngJob.Address = strFirstAddress
                'Print the final total in the cell.
                r = intTotal
            End If
        End If
    Next r
   
   With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With

End Sub

Version 2 (with arrays)

Sub Check_Duties_Array()
    Dim wsData As Worksheet, wsNotifications As Worksheet, r As Range, i As Long, j As Integer, intTotal As Integer
    Dim msgContinue As VbMsgBoxResult, rngDuties As Range, arrData As Variant
    Dim strJob As String, strCompare As String, blnNotify As Boolean
   
    msgContinue = MsgBox(Prompt:="CAUTION!! This process can take several minutes to complete. " & _
                                 "During this time, you will not be able to use Excel. " & _
                                 "Are you sure you wish to continue?", _
                         Buttons:=vbYesNo + vbExclamation + vbDefaultButton2, _
                         Title:="Extended Processing Time Required")
    If msgContinue = vbNo Then Exit Sub
                   
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
   
    'Set the major variables that will be used throughout the code
    Set wsData = Sheets("Access Data")
    Set wsNotifications = Sheets("SOD Notifications")
    Set rngDuties = Range(Cells(2, "C"), Cells(Cells(Rows.Count, "B").End(xlUp).Row, Cells(1, Columns.Count).End(xlToLeft).Column))
   
    'Clear any existing data to start fresh. Note that cell fill colors are intentionally left intact.
    wsNotifications.Range("A2:C" & wsNotifications.Cells(Rows.Count, "A").End(xlUp).Offset(1).Row).ClearContents
    rngDuties.ClearContents
   
    'Create a 2 dimensional array with the "User" and "Job Name" fields in it.
    arrData = wsData.ListObjects(1).DataBodyRange.Value2
    arrData = Application.Index(arrData, Evaluate("row(1:" & UBound(arrData) & ")"), Array(1, 5))
       
    For Each r In rngDuties
        strJob = Cells(r.Row, "B")
        strCompare = Cells(1, r.Column)
        If r.Interior.Color = vbRed Then blnNotify = True
        'Make sure that the row and column values are different.
        If strJob <> strCompare Then
            'Reset the count of users.
            intTotal = 0
            For i = 1 To UBound(arrData, 1)
                If arrData(i, 2) = strJob Then
                    For j = 1 To UBound(arrData, 1)
                        If arrData(j, 1) = arrData(i, 1) And arrData(j, 2) = strCompare Then
                            intTotal = intTotal + 1
                            'If there are any undesired combinations of duties, highlighting the cell in red will cause the SOD Notifications tab to _
                             display the user and their conflict of duties.
                            If blnNotify Then
                                With wsNotifications
                                    .Cells(Rows.Count, "A").End(xlUp).Offset(1) = arrData(i, 1)
                                    .Cells(Rows.Count, "B").End(xlUp).Offset(1) = arrData(i, 2)
                                    .Cells(Rows.Count, "C").End(xlUp).Offset(1) = strCompare
                                End With
                            End If
                        End If
                    Next j
                End If
            Next i
        r = intTotal
        blnNotify = False
        End If
    Next r
   
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With

End Sub

 

[DanteAmor]

Hopefully we can figure out how to get a count of each job intersection

Here the complete code with the counter. But check the "AX" (PO Receipts by Container) column of the "SOD Testing" sheet, because my counter is different from yours.

Sub Check_Duties_Array_3()
  Dim a As Variant, b As Variant, c As Variant, d As Variant
  Dim wsSod As Worksheet, wsData As Worksheet
  Dim i As Long, j As Long, lr As Long, lc As Long, m  As Long, n As Long
  Dim f As Range, rngDuties As Range
  Dim dic1 As Object, dic2 As Object, dic3 As Object, dic4 As Object
  Dim cell As String
  Dim ky1 As Variant, ky2 As Variant, ky3 As Variant, ky4 As Variant
  
  Set wsSod = Sheets("SOD Testing")
  Set wsData = Sheets("Access Data")
  
  Set dic1 = CreateObject("Scripting.Dictionary")
  Set dic2 = CreateObject("Scripting.Dictionary")
  Set dic3 = CreateObject("Scripting.Dictionary")
  Set dic4 = CreateObject("Scripting.Dictionary")

  lr = wsSod.Range("B" & Rows.Count).End(3).Row
  lc = wsSod.Cells(1, Columns.Count).End(1).Column
  Set rngDuties = wsSod.Range("C2", wsSod.Cells(lr, lc))
  
  Application.FindFormat.Clear
  Application.FindFormat.Interior.ColorIndex = 3
  Set f = rngDuties.Find("", rngDuties.Cells(1), xlFormulas, xlPart, xlByRows, xlNext, False, SearchFormat:=True)
  If Not f Is Nothing Then
    cell = f.Address
    Do
      dic1(wsSod.Cells(f.Row, "B").Value & "|" & wsSod.Cells(1, f.Column).Value) = Empty
      Set f = rngDuties.Find("", f, xlValues, xlWhole, xlByRows, xlNext, False, SearchFormat:=True)
    Loop While f.Address <> cell
  End If
  Application.FindFormat.Clear
  
  a = wsData.ListObjects(1).DataBodyRange.Value2
  ReDim b(1 To UBound(a, 1), 1 To 3)

  For i = 1 To UBound(a, 1)
    dic2(a(i, 1)) = Empty
    dic3(a(i, 1) & "|" & a(i, 5)) = Empty
  Next
  
  c = wsSod.Range("B2:B" & lr).Value
  ReDim d(1 To UBound(c, 1), 1 To UBound(c, 1))
  
  For i = 1 To UBound(c, 1)
    For j = 1 To UBound(c, 1)
      If c(i, 1) <> c(j, 1) Then
        dic4(c(i, 1) & "|" & c(j, 1)) = i & "|" & j
      End If
    Next
  Next

  For Each ky3 In dic2.keys     'users
    For Each ky1 In dic1.keys   'red cells
      If dic3.exists(ky3 & "|" & Split(ky1, "|")(0)) And _
         dic3.exists(ky3 & "|" & Split(ky1, "|")(1)) Then
        j = j + 1
        b(j, 1) = ky3
        b(j, 2) = Split(ky1, "|")(0)
        b(j, 3) = Split(ky1, "|")(1)
      End If
    Next
    
    For Each ky4 In dic4.keys     'Combinations
      If dic3.exists(ky3 & "|" & Split(ky4, "|")(0)) And _
         dic3.exists(ky3 & "|" & Split(ky4, "|")(1)) Then
        m = Split(dic4(ky4), "|")(0)
        n = Split(dic4(ky4), "|")(1)
        d(m, n) = d(m, n) + 1
      End If
    Next
  Next
  
  Sheets("SOD Notifications").Range("E2").Resize(j, 3).Value = b
  wsSod.Range("C2").Resize(UBound(d, 1), UBound(d, 2)).Value = d
End Sub

I hope to have time in the afternoon to code with the alternative of job combinations in a table, instead of red cells.

 

[Veritan]

Here the complete code with the counter.

I can't begin to thank you enough! This is working amazingly! ? With 2000 records containing 300 unique jobs, and filling in over 88,000 cells, it finishes in about 10-15 seconds! It's difficult to check manually (hence the reason for the code in the first place, lol), but so far, every check has come back correctly. The only changes I had to make were to add back in your original code for putting in the list of users and jobs on the "SOD Notifications" sheet where it was originally (not sure why the position matters, but for some reason it does) and then to add a very minor check to make sure that dic1 actually has something in it before pasting. I'm going to post the final code here in case anyone else needs something like this in the future, and then mark this post as the solution. However, 100% of the credit goes to you. Thank you so much, Dante!

Option Explicit

Sub Check_Duties_Array_3()
  Dim a As Variant, b As Variant, c As Variant, d As Variant
  Dim wsSod As Worksheet, wsData As Worksheet
  Dim i As Long, j As Long, lr As Long, lc As Long, m  As Long, n As Long
  Dim f As Range, rngDuties As Range
  Dim dic1 As Object, dic2 As Object, dic3 As Object, dic4 As Object
  Dim cell As String
  Dim ky1 As Variant, ky2 As Variant, ky3 As Variant, ky4 As Variant
  
  Set wsSod = Sheets("SOD Testing")
  Set wsData = Sheets("Access Data")
  
  Set dic1 = CreateObject("Scripting.Dictionary")
  Set dic2 = CreateObject("Scripting.Dictionary")
  Set dic3 = CreateObject("Scripting.Dictionary")
  Set dic4 = CreateObject("Scripting.Dictionary")

  lr = wsSod.Range("B" & Rows.Count).End(3).Row
  lc = wsSod.Cells(1, Columns.Count).End(1).Column
  Set rngDuties = wsSod.Range("C2", wsSod.Cells(lr, lc))
  
  Application.FindFormat.Clear
  Application.FindFormat.Interior.ColorIndex = 3
  Set f = rngDuties.Find("", rngDuties.Cells(1), xlFormulas, xlPart, xlByRows, xlNext, False, SearchFormat:=True)
  If Not f Is Nothing Then
    cell = f.Address
    Do
      dic1(wsSod.Cells(f.Row, "B").Value & "|" & wsSod.Cells(1, f.Column).Value) = Empty
      Set f = rngDuties.Find("", f, xlValues, xlWhole, xlByRows, xlNext, False, SearchFormat:=True)
    Loop While f.Address <> cell
  End If
  Application.FindFormat.Clear
  
  a = wsData.ListObjects(1).DataBodyRange.Value2
  ReDim b(1 To UBound(a, 1), 1 To 3)

  For i = 1 To UBound(a, 1)
    dic2(a(i, 1)) = Empty
    dic3(a(i, 1) & "|" & a(i, 5)) = Empty
  Next
  
  For Each ky3 In dic2.keys     'users
    For Each ky1 In dic1.keys   'red cells
      If dic3.exists(ky3 & "|" & Split(ky1, "|")(0)) And _
         dic3.exists(ky3 & "|" & Split(ky1, "|")(1)) Then
        j = j + 1
        b(j, 1) = ky3
        b(j, 2) = Split(ky1, "|")(0)
        b(j, 3) = Split(ky1, "|")(1)
      End If
    Next
  Next
  
  If dic1.Count > 0 Then Sheets("SOD Notifications").Range("A2").Resize(j, 3).Value = b
  
  c = wsSod.Range("B2:B" & lr).Value
  ReDim d(1 To UBound(c, 1), 1 To UBound(c, 1))
  
  For i = 1 To UBound(c, 1)
    For j = 1 To UBound(c, 1)
      If c(i, 1) <> c(j, 1) Then
        dic4(c(i, 1) & "|" & c(j, 1)) = i & "|" & j
      End If
    Next
  Next

  For Each ky3 In dic2.keys     'users
    For Each ky4 In dic4.keys     'Combinations
      If dic3.exists(ky3 & "|" & Split(ky4, "|")(0)) And _
         dic3.exists(ky3 & "|" & Split(ky4, "|")(1)) Then
        m = Split(dic4(ky4), "|")(0)
        n = Split(dic4(ky4), "|")(1)
        d(m, n) = d(m, n) + 1
      End If
    Next
  Next
  
  wsSod.Range("C2").Resize(UBound(d, 1), UBound(d, 2)).Value = d
End Sub

 

[DanteAmor]

This is working amazingly! ? With 2000 records containing 300 unique jobs, and filling in over 88,000 cells, it finishes in about 10-15 seconds!

But I'm also going to check if I can improve the code to make it faster. Just as a fact, in how long was it done with your macros?

and then mark this post as the solution.

I like to put the output at the end of the code (input-process-output). In the same way so that you mark my answer as a solution.

Sub Check_Duties_Array_3()
  Dim a As Variant, b As Variant, c As Variant, d As Variant
  Dim wsSod As Worksheet, wsData As Worksheet
  Dim i As Long, j As Long, lr As Long, lc As Long, m  As Long, n As Long
  Dim f As Range, rngDuties As Range
  Dim dic1 As Object, dic2 As Object, dic3 As Object, dic4 As Object
  Dim cell As String
  Dim ky1 As Variant, ky2 As Variant, ky3 As Variant, ky4 As Variant
  
  Set wsSod = Sheets("SOD Testing")
  Set wsData = Sheets("Access Data")
  
  Set dic1 = CreateObject("Scripting.Dictionary")
  Set dic2 = CreateObject("Scripting.Dictionary")
  Set dic3 = CreateObject("Scripting.Dictionary")
  Set dic4 = CreateObject("Scripting.Dictionary")

  lr = wsSod.Range("B" & Rows.Count).End(3).Row
  lc = wsSod.Cells(1, Columns.Count).End(1).Column
  Set rngDuties = wsSod.Range("C2", wsSod.Cells(lr, lc))
  
  Application.FindFormat.Clear
  Application.FindFormat.Interior.ColorIndex = 3
  Set f = rngDuties.Find("", rngDuties.Cells(1), xlFormulas, xlPart, xlByRows, xlNext, False, SearchFormat:=True)
  If Not f Is Nothing Then
    cell = f.Address
    Do
      dic1(wsSod.Cells(f.Row, "B").Value & "|" & wsSod.Cells(1, f.Column).Value) = Empty
      Set f = rngDuties.Find("", f, xlValues, xlWhole, xlByRows, xlNext, False, SearchFormat:=True)
    Loop While f.Address <> cell
  End If
  Application.FindFormat.Clear
  
  a = wsData.ListObjects(1).DataBodyRange.Value2
  ReDim b(1 To UBound(a, 1), 1 To 3)

  For i = 1 To UBound(a, 1)
    dic2(a(i, 1)) = Empty
    dic3(a(i, 1) & "|" & a(i, 5)) = Empty
  Next
  
  c = wsSod.Range("B2:B" & lr).Value
  ReDim d(1 To UBound(c, 1), 1 To UBound(c, 1))
  
  For i = 1 To UBound(c, 1)
    For j = 1 To UBound(c, 1)
      If c(i, 1) <> c(j, 1) Then
        dic4(c(i, 1) & "|" & c(j, 1)) = i & "|" & j
      End If
    Next
  Next

  For Each ky3 In dic2.keys     'users
    For Each ky1 In dic1.keys   'red cells
      If dic3.exists(ky3 & "|" & Split(ky1, "|")(0)) And _
         dic3.exists(ky3 & "|" & Split(ky1, "|")(1)) Then
        j = j + 1
        b(j, 1) = ky3
        b(j, 2) = Split(ky1, "|")(0)
        b(j, 3) = Split(ky1, "|")(1)
      End If
    Next
    
    For Each ky4 In dic4.keys     'Combinations
      If dic3.exists(ky3 & "|" & Split(ky4, "|")(0)) And _
         dic3.exists(ky3 & "|" & Split(ky4, "|")(1)) Then
        m = Split(dic4(ky4), "|")(0)
        n = Split(dic4(ky4), "|")(1)
        d(m, n) = d(m, n) + 1
      End If
    Next
  Next
  
  If dic1.Count > 0 Then Sheets("SOD Notifications").Range("E2").Resize(j, 3).Value = b
  wsSod.Range("C2").Resize(UBound(d, 1), UBound(d, 2)).Value = d
End Sub

 

[Veritan]

In the same way so that you mark my answer as a solution.

Done

Just as a fact, in how long was it done with your macros?

It was taking me about 15 minutes to run with my old macros, so this is a massive improvement.

I've been testing continuously, and I think it must have been user error on my part that caused it not to put the listing of users and jobs in. It seems to be working completely now.

 

[DanteAmor]

It's difficult to check manually (hence the reason for the code in the first place, lol)

The counts that your macro threw out, from my point of view were incorrect. My macro counts seem right. But you should review a sizable sample of data to corroborate that the counts are correct.

 

[DanteAmor]

I already found to perform the combinations of jobs of each user, in a more efficient way. Try the following code, it should be faster. It's longer, with more variables and more indices, but I think it's worth it.

Sub Check_Duties_Array_4()
  Dim a As Variant, b As Variant, c As Variant, d As Variant
  Dim wsSod As Worksheet, wsData As Worksheet
  Dim i As Long, j As Long, lr As Long, lc As Long, m As Long, n As Long, ini As Long, fin As Long
  Dim f As Range, rngDuties As Range
  Dim dic1 As Object, dic2 As Object, dic3 As Object, dicx As Object, dicy As Object, dicz As Object
  Dim cell As String, llave As String, llave3 As String
  Dim ky1 As Variant, ky2 As Variant, kyx As Variant, kyy As Variant
  
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual
  
  Set wsSod = Sheets("SOD Testing")
  Set wsData = Sheets("Access Data")

  Set dic1 = CreateObject("Scripting.Dictionary")
  Set dic2 = CreateObject("Scripting.Dictionary")
  Set dic3 = CreateObject("Scripting.Dictionary")
  Set dicx = CreateObject("Scripting.Dictionary")
  Set dicy = CreateObject("Scripting.Dictionary")
  Set dicz = CreateObject("Scripting.Dictionary")
  
  lr = wsSod.Range("B" & Rows.Count).End(3).Row
  lc = wsSod.Cells(1, Columns.Count).End(1).Column
  Set rngDuties = wsSod.Range("C2", wsSod.Cells(lr, lc))
  
  'SOD Notifications, Because there are red cells
  Application.FindFormat.Clear
  Application.FindFormat.Interior.ColorIndex = 3
  Set f = rngDuties.Find("", rngDuties.Cells(1), xlFormulas, xlPart, xlByRows, xlNext, False, SearchFormat:=True)
  If Not f Is Nothing Then
    cell = f.Address
    Do
      dic1(wsSod.Cells(f.Row, "B").Value & "|" & wsSod.Cells(1, f.Column).Value) = Empty
      Set f = rngDuties.Find("", f, xlValues, xlWhole, xlByRows, xlNext, False, SearchFormat:=True)
    Loop While f.Address <> cell
  End If
  Application.FindFormat.Clear
  a = wsData.ListObjects(1).DataBodyRange.Value2
  ReDim b(1 To UBound(a, 1), 1 To 3)
  
  For i = 1 To UBound(a, 1)
    dic2(a(i, 1)) = Empty
    dic3(a(i, 1) & "|" & a(i, 5)) = Empty
  Next
  For Each ky2 In dic2.keys     'users
    For Each ky1 In dic1.keys   'red cells
      If dic3.exists(ky2 & "|" & Split(ky1, "|")(0)) And _
         dic3.exists(ky2 & "|" & Split(ky1, "|")(1)) Then
        j = j + 1
        b(j, 1) = ky2
        b(j, 2) = Split(ky1, "|")(0)
        b(j, 3) = Split(ky1, "|")(1)
      End If
    Next
  Next
  
  'Access Data - COMBINATIONS
  For i = 1 To UBound(a, 1)
    If Not dicx.exists(a(i, 1)) Then
      dicx(a(i, 1)) = i & "|" & i
    Else
      dicx(a(i, 1)) = Split(dicx(a(i, 1)), "|")(0) & "|" & i
    End If
  Next
  For Each kyx In dicx.keys
    ini = Split(dicx(kyx), "|")(0)
    fin = Split(dicx(kyx), "|")(1)
    For i = ini To fin
      For j = ini To fin
        'counts by combination
        llave3 = a(i, 1) & "|" & a(i, 5) & "|" & a(j, 5)
        If Not dicz.exists(llave3) Then
          dicz(llave3) = Empty
          llave = a(i, 5) & "|" & a(j, 5)
          If i <> j Then dicy(llave) = dicy(llave) + 1
        End If
      Next
    Next
  Next
  
  'SOD Testing, put Counts
  c = wsSod.Range("B1", wsSod.Cells(lr, lc)).Value
  ReDim d(1 To UBound(c, 1) - 1, 1 To UBound(c, 2) - 1)
  For i = 2 To UBound(c, 1)
    m = m + 1
    n = 0
    For j = 2 To UBound(c, 2)
      n = n + 1
      d(m, n) = dicy(c(i, 1) & "|" & c(1, j))
    Next
  Next

  If dic1.Count > 0 Then Sheets("SOD Notifications").Range("A2").Resize(j, 3).Value = b
  wsSod.Range("C2").Resize(UBound(d, 1), UBound(d, 2)).Value = d

  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Application.Calculation = xlCalculationAutomatic
End Sub

 

[Veritan]

This is incredible. It's completing the entire sheet in just about 5 seconds. I'm extremely impressed with the level of optimization that you managed to achieve with this. Thank you so much for all your help!

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.