Code used for comparison between 2 list.

[Phaedrus1301]

Hello,
I am fairly new to VBA and I was given a task regarding it, I am using MS Excel 2010. Here is my attempt to explain my end goal and code I've written till now to reach the same.

Workbook1 has Sheet1,
Col A has `uniqueProductID` from company A
Col B has `Price`
Col D has `uniqueProductID` from company B
Col E has `Price`

I was trying to write a vba script, which checks for matching unique ID's in both col A & col B and then once the id is matching it should put data in sheet2
Col A - `UniqueMatchedID`
Col B - `Price from company A`
Col C - `Price from company B`
I wrote small vb script for this (code below this), which is running without any errors however it is not giving any output, can someone please guide me with this?

Sub CompareAndCopy()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim lastRow1 As Long
    Dim lastRow2 As Long
    Dim i As Long
    Dim j As Long
    Dim rowNum As Long
   
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("Sheet2")
   
    lastRow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
    lastRow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
   
    rowNum = 2
   
    For i = 3 To lastRow1
        For j = 3 To lastRow1
            If ws1.Cells(i, "A").Value = ws1.Cells(j, "D").Value Then
                ws2.Cells(rowNum, "A").Value = ws1.Cells(i, "A").Value
                ws2.Cells(rowNum, "B").Value = ws1.Cells(i, "B").Value
                ws2.Cells(rowNum, "C").Value = ws1.Cells(j, "E").Value
                rowNum = rowNum + 1
            End If
        Next j
    Next i
   
    MsgBox "Comparison and copying completed!", vbInformation
End Sub

PS - I have started both loops from free as 1st row contains of merged block of company name and then 2 contains title, data starts from the 3rd. I am also attaching images for sheet1 and sheet2 expected data as that might help.
Thanks in advanced for all your help.

 

[jimrward]

If you are not getting any output it would suggest your cell comparison line isn’t working
You could set a break point in the code on the line below your IF click with the mouse in the left border of the vba window you should get a dark spot in the border next run the macro to see if it halts there if it doesn’t then you need to work on the cell comparison line

 

[Phaedrus1301]

If you are not getting any output it would suggest your cell comparison line isn’t working
You could set a break point in the code on the line below your IF click with the mouse in the left border of the vba window you should get a dark spot in the border next run the macro to see if it halts there if it doesn’t then you need to work on the cell comparison line

Sorry for the late response, but yes that seems to be the case. I am getting no matches, could you guide me on how can I reconfigure the if condition?
I have tried this but same output.

If IIf(ws1.Cells(i, "A").Value = ws1.Cells(j, "D").Value, True, False) Then

 

[Tupe77]

Do you mean something like this?

Sub TS_CompareLists()
    Dim ws1 As Worksheet: Set ws1 = Worksheets(1) 
    Dim ws2 As Worksheet: Set ws2 = Worksheets(2)
    Dim Company1 As Range: Set Company1 = ws1.Range("A1").CurrentRegion.Offset(2, 0).Resize(ws1.Range("A1").CurrentRegion.Rows.Count - 2, 2)
    Dim Company2 As Range: Set Company2 = ws1.Range("D1").CurrentRegion.Offset(2, 0).Resize(ws1.Range("D1").CurrentRegion.Rows.Count - 2, 2)
    Dim Comp1ARR As Variant: Comp1ARR = Company1.Value2
    Dim Comp2ARR As Variant: Comp2ARR = Company2.Value2
    Dim iRow As Long
    
    
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary"): dict.CompareMode = vbTextCompare ' Create Dictionary for UID

' ***** Reading
For iRow = 1 To UBound(Comp1ARR, 1) ' Read the Company1 list values into the dictionary
    If dict.Exists(Comp1ARR(iRow, 1)) Then
        MsgBox "Company1 list contains duplicates!" & dict(Comp1ARR(iRow, 1))
    Else
        dict.Add Comp1ARR(iRow, 1), Comp1ARR(iRow, 2)
    End If
Next iRow

' ***** Comparing
Dim coll As New Collection
For iRow = 1 To UBound(Comp2ARR, 1) ' Read the values in the Company2 list and compare them to the values in the dictionary
    If dict.Exists(Comp2ARR(iRow, 1)) Then
        coll.Add Array(Comp2ARR(iRow, 1), dict(Comp2ARR(iRow, 1)), Comp2ARR(iRow, 2)) ' UIDs found in the Company1 and Company2 lists are added to the Collection.
    Else
        ' Company2 list UID is unique.
    End If
Next iRow

' ***** Writing
Dim returRNG As Range: Set returRNG = ws2.Range("A3:A" & coll.Count + 2)
For iRow = 1 To coll.Count
    returRNG(iRow).Resize(1, 3).Value2 = coll(iRow)
Next iRow

End Sub

My apologies for any quirks, English is not my native language. "So I blame Google translate for all my goofs."