VBA - Comparing columns based on the values in 2 columns with an input table

[omninoob]

Hello everyone, I would really appreciate your help with this. I have tried many various methods by using a nested for-loop which causes excel to hang, probably having too many cells to work with and I am almost clueless how to work with Arrays. This is just a sample of the project which up to 10-20 thousand cells.

Added Box Link

I have 4 Sheets: The first sheet is filled in by the Users, which Compares the values of A4 to B4; A5 to A6, etc.

The Remaining 3 sheets, comparing unique values based on the Project's Design to Columns. Example: ProjectA2 to ProjectA1's Design to Design, Koi to Koi.

The results only require what is removed or added with the column header.
Also, if a Design is removed or added, all subsequent compared columns are not required to be added. (Shown in Example ProjectE2 to ProjectE1)

Thank you very much!

 

[Legacy 143009]

Why not Micro Country US?

ProjectE1

Micro

-

-

Removed

 

[omninoob]

Yes this can work too, as long as I’m able to get something similar to the results

 

[Legacy 143009]

Please find the test file below. The code is in Results sheet. Also I am sharing the working code:

Project.xlsm

1 file sent via WeTransfer, the simplest way to send your files around the world

we.tl

Sub test()
  Dim projects As Object, pastProjects As Object, presentProjects As Object, pastProjectsCopy As Object, presentProjectsCopy As Object
  Dim projectTable As Variant, present As Variant, past As Variant, results As Variant, c As Long, myresult As Variant
  Dim table As Worksheet
  Set table = Worksheets("Table")
  present = Worksheets("Present").UsedRange
  past = Worksheets("Past").UsedRange
  ReDim results(1 To 5, 1 To 1)
  Set projects = CreateObject("Scripting.dictionary")
  Set pastProjects = CreateObject("Scripting.dictionary")
  Set presentProjects = CreateObject("Scripting.dictionary")
  Set pastProjectsCopy = CreateObject("Scripting.dictionary")
  Set presentProjectsCopy = CreateObject("Scripting.dictionary")
  projectTable = table.Range("A3:B" & table.Range("A" & Rows.Count).End(xlUp).Row)
  
  For i = 2 To UBound(projectTable)
    projects(projectTable(i, 1)) = projectTable(i, 2)
  Next
  
  With Application
  For i = 2 To UBound(past)
    pastProjects(Join(Array(past(i, 1), past(i, 2), past(i, 3), past(i, 4)), ";")) = Join(.Index(past, i, 0), ";")
    pastProjectsCopy(Join(Array(past(i, 1), past(i, 2), past(i, 4)), ";")) = i
  Next
    For i = 2 To UBound(present)
    presentProjects(Join(Array(projects(present(i, 1)), present(i, 2), present(i, 3), present(i, 4)), ";")) = Join(.Index(present, i, 0), ";")
    presentProjectsCopy(Join(Array(projects(present(i, 1)), present(i, 2), present(i, 3), present(i, 4)), ";")) = Join(Array(projects(present(i, 1)), present(i, 2), present(i, 4)), ";")
  Next
  
  c = 1
  For Each projectKey In projects.keys
    For Each presentProjectKey In presentProjects.keys
      If InStr(presentProjectKey, projects(projectKey)) > 0 Then
        If Not pastProjects.exists(presentProjectKey) Then
          ReDim Preserve results(1 To 5, 1 To c)
          results(1, c) = Split(presentProjects(presentProjectKey), ";")(0)
          results(2, c) = Split(presentProjectKey, ";")(1)
          If pastProjectsCopy.exists(presentProjectsCopy(presentProjectKey)) Then
            results(3, c) = "Volume"
            results(4, c) = Split(presentProjectKey, ";")(2)
          Else
            results(3, c) = "Country"
            results(4, c) = Split(presentProjectKey, ";")(3)
          End If
          results(5, c) = "Added"
          c = c + 1
        End If
      End If
    Next
    For Each pastProjectKey In pastProjects.keys
      If InStr(pastProjectKey, projects(projectKey)) > 0 Then
        If Not presentProjects.exists(pastProjectKey) Then
          ReDim Preserve results(1 To 5, 1 To c)
          results(1, c) = Split(pastProjects(pastProjectKey), ";")(0)
          results(2, c) = Split(pastProjectKey, ";")(1)
          results(3, c) = "Country"
          results(4, c) = Split(pastProjectKey, ";")(3)
          results(5, c) = "Removed"
          c = c + 1
        End If
      End If
    Next
  Next
  Worksheets("Results").Range("A2").Resize(UBound(results, 2), UBound(results, 1)) = .Transpose(results)
  End With
End Sub