Excel VBA to Access VBA: Filter Function

Question

A while back, I wrote an Excel script to compare two Arrays, A and B. Each array represents the regulations applicable to a document's revision, and this script uses the Filter function to identify any differences between them. I've included a custom version of the code below:

Sub Main()
    Dim ArrA() As String
    Dim ArrB() As String
    Dim ArrC() As String
    Dim i As Integer
    Dim j As Integer
    Dim x As Integer
    Dim ws As Worksheet
    
    Set ws = ActiveWorkbook.Worksheets("Sheet1")
    
    With ws
        ArrA = Split(Left(.Cells(1, 2), Len(.Cells(1, 2)) - 1), ", ")
        ArrB = Split(Left(.Cells(2, 2), Len(.Cells(2, 2)) - 1), ", ")

        ArrC = ArrB
        For i = 0 To UBound(ArrA)
            ArrC = Filter(ArrC, ArrA(i), False)
        Next i
        Debug.Print "Added: " & Join(ArrC, ", ") & ","
        .Cells(4, 2) = Join(ArrC, ", ") & ","
        .Cells(8, 2) = SortCFR(Join(ArrA, ", ") & ", " & Join(ArrC, ", ") & ",")
        
        ArrC = ArrA
        For i = 0 To UBound(ArrB)
            ArrC = Filter(ArrC, ArrB(i), False)
        Next i
        Debug.Print "Removed: " & Join(ArrC, ", ") & ","
        .Cells(5, 2) = Join(ArrC, ", ") & ","
        
        For i = 0 To UBound(ArrC)
            ArrA = Filter(ArrA, ArrC(i), False)
        Next i
        Debug.Print "Sustained: " & Join(ArrA, ", ") & ","
        .Cells(6, 2) = Join(ArrA, ", ") & ","
        
        ArrA = Split(Left(.Cells(4, 2), Len(.Cells(4, 2)) - 1), ", ")
        ArrB = Split(Left(.Cells(5, 2), Len(.Cells(5, 2)) - 1), ", ")
        ArrC = Split(Left(.Cells(8, 2), Len(.Cells(8, 2)) - 1), ", ")
        
        x = 1
        For i = 0 To UBound(ArrC)
            For j = 0 To UBound(ArrA)
                If ArrC(i) = ArrA(j) Then
                    With .Cells(8, 2).Characters(Start:=x, Length:=Len(ArrC(i)) + 1).Font
                        .Underline = True
                        .Color = RGB(0, 0, 255)
                        GoTo Jump
                    End With
                End If
            Next j
            
            For j = 0 To UBound(ArrB)
                If ArrC(i) = ArrB(j) Then
                    With .Cells(8, 2).Characters(Start:=x, Length:=Len(ArrC(i)) + 1).Font
                        .Strikethrough = True
                        .Color = RGB(255, 0, 0)
                        GoTo Jump
                    End With
                End If
            Next j
Jump:
            x = x + Len(ArrC(i)) + 2
        Next i
    End With
End Sub

SortCFR is a custom sorting algorithm; we prefer to sort these regulations suffix-first, prefix-second.

Cell B1 includes the regulations for the prior revision. B2 includes the regulations for the new revision. B4 includes all regulations that were added to the new revision. B5 includes all regulations that were removed since the previous revision. B6 lists all regulations maintained between both revisions and isn't actually used. B8 is a formatted list of all the regulations between both revisions. Everything removed is colored red and struck through. Everything added is colored blue and underlined. You can view an example of the script's output below:

It works great in Excel, and I want to use this script in my Access database as well, but Access doesn't support VBA's Filter function. I've gotten a modified version of this script working that individually compares the elements of each array, but it's slower. Is there anything equivalent to the Filter function in Access? Should I just reverse-engineer it and implement it as a Module?

Answer 1

An alternative approach using a Dictionary Object.

Option Explicit

Sub DEMO()

   Dim ar, ar1, ar2, dict, k, arI, arJ, tmp As String
   Dim c As Long, n As Long, i As Long, j As Long
   Set dict = CreateObject("Scripting.Dictionary")

   ' test values
   ar1 = Split("a.a,a.b,a.c,a.d,a.e,a.f,b.a", ",")
   ar2 = Split("a.z,a.b,a.y,a.d,a.x,a.f", ",")
   
   ' determine changes
   For Each k In ar1
      dict.Add k, -1 ' assume deleted
   Next
   
   For Each k In ar2
      If dict.exists(k) Then
         dict(k) = 0 ' existing
      Else
         dict.Add k, 1 ' added
      End If
   Next

   ' sort
   ar = dict.keys
   n = dict.Count
   For i = 0 To n - 2
      arI = Split(ar(i), ".")
      For j = i + 1 To n - 1
        arJ = Split(ar(j), ".")
        
        If arI(1) > arJ(1) Or _
           (arI(1) = arJ(1) And arI(0) > arJ(0)) Then
           tmp = ar(i)
           ar(i) = ar(j)
           ar(j) = tmp
        End If
      Next
    Next
    
    ' result to sheet
    Cells(1, 1).Clear
    Cells(1, 1) = Join(ar, ", ")
    
    ' format string
    c = 1
    For Each k In ar
       n = Len(k)
       With Cells(1, 1).Characters(Start:=c, Length:=n).Font
          If dict(k) = 1 Then
             .Underline = True
             .Color = RGB(0, 0, 255)
          ElseIf dict(k) = -1 Then
             .Strikethrough = True
             .Color = RGB(255, 0, 0)
          End If
       End With
       c = c + n + 2
    Next

End Sub