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

omninoob

New Member
Joined
Dec 23, 2018
Messages
3
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)

1682474905054.png


1682474934123.png



Thank you very much!
 

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).
Please find the test file below. The code is in Results sheet. Also I am sharing the working code:
VBA Code:
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
 
Upvote 0

Forum statistics

Threads
1,223,901
Messages
6,175,277
Members
452,629
Latest member
SahilPolekar

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top