Compare row of data from different workbooks using another workbook - excel vba

Hello.

I have a host excel workbook which contains all the VBA Codes. When I click a button there, it must compare two workbook's data and generate a report file.

Workbook Data 1 contains this:

Workbook Data 2 contains this:

ID 1 must only be compared to ID 1 and so on thus generating a report file:

The Workbook Data 2 offsets and adjusts its placement in the row if they have NO MATCH.

Then ALIGNS to the Workbook Data 1 if the ROW of data are all the SAME with a REMARKS on the last column as MATCH.

I have tried making this code and this is as far as I have gone to:

In this code, I tried pasting the data of two workbooks to one workbook but I can't seem to know how to compare them from there.

Sub copyData()
    Dim Report0 As Variant
    Dim sReport0 As String
        sReport0 = ThisWorkbook.path & Application.PathSeparator & "\DATACOMPARE\Report.xlsx"
    Set Report0 = Workbooks.Open(sReport0, ReadOnly:=False)
    
    Dim Temp01 As Variant
    Dim sTemp01 As String
        sTemp01 = ThisWorkbook.path & Application.PathSeparator & "\DATACOMPARE\File1.xlsx"
    Set Temp01 = Workbooks.Open(sTemp01, ReadOnly:=False)
    
    Dim Temp02 As Variant
    Dim sTemp02 As String
        sTemp02 = ThisWorkbook.path & Application.PathSeparator & "\DATACOMPARE\File2.xlsx"
    Set Temp02 = Workbooks.Open(sTemp02, ReadOnly:=False)
    Application.ScreenUpdating = False



    Workbooks("File1.xlsx").Worksheets(1).Range("B1:E200").Copy
    Workbooks("Report.xlsx").Worksheets(1).Range("B1").PasteSpecial Paste:=xlPasteValues
  
    Workbooks("File2.xlsx").Worksheets(1).Range("B1:E200").Copy
    Workbooks("Report.xlsx").Worksheets(2).Range("B1").PasteSpecial Paste:=xlPasteValues
  
    Application.DisplayAlerts = False
    Workbooks("File1.xlsx").Close
    Workbooks("File2.xlsx").Close
    Application.ScreenUpdating = True
  

End Sub

Please help anyone. Thank you.

royUK Hello master. Please help me if you have the time. Thank you.

Quote from Mumps

It's hard to work with pictures. It would be easier to help if you could attach copies of your files.

Here is the zip file that contains the files.

Quote from Mumps

Try:

Code

Sub Button1_Click()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, LastRow As Long, arr1 As Variant, arr2 As Variant, Val As String, rngList As Object
    Workbooks.Open ThisWorkbook.Path & "\" & "DATACOMPARE\Report.xlsx"
    Set desWS = Sheets(1)
    Workbooks.Open ThisWorkbook.Path & "\" & "DATACOMPARE\File1.xlsx"
    With Sheets(1)
        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        .Range("B1:E" & LastRow).Copy
        desWS.Range("B1").PasteSpecial Paste:=xlPasteValues
    End With
    Application.CutCopyMode = False
    Workbooks("File1.xlsx").Close False
    Workbooks.Open ThisWorkbook.Path & "\" & "DATACOMPARE\File2.xlsx"
    With Sheets(1)
        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        .Range("B1:E" & LastRow).Copy
        desWS.Range("G1").PasteSpecial Paste:=xlPasteValues
    End With
    Application.CutCopyMode = False
    Workbooks("File2.xlsx").Close False
    arr1 = Range("B2", Range("B" & Rows.Count).End(xlUp)).Resize(, 4).Value
    arr2 = Range("G2", desWS.Range("G" & Rows.Count).End(xlUp)).Resize(, 4).Value
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
    Set rngList = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(arr1, 1)
        Val = arr1(i, 1) & "|" & arr1(i, 2) & "|" & arr1(i, 3) & "|" & arr1(i, 4)
        If Not rngList.Exists(Val) Then
            rngList.Add Val, Nothing
        End If
    Next i
    For i = 1 To UBound(arr2, 1)
        Val = arr2(i, 1) & "|" & arr2(i, 2) & "|" & arr2(i, 3) & "|" & arr2(i, 4)
        If rngList.Exists(Val) Then
            With desWS.Range("K" & i + 1)
                .Value = "MATCH"
                .Interior.ColorIndex = 4
            End With
        Else
            desWS.Range("G" & LastRow).Resize(, 4) = Array(arr2(i, 1), arr2(i, 2), arr2(i, 3), arr2(i, 4))
            With desWS.Range("K" & LastRow)
                .Value = "NO MATCH"
                .Interior.ColorIndex = 3
            End With
            LastRow = LastRow + 1
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

Display More

This works like a charm! THANK YOU SO MUCH!

Quote from Mumps

You are very welcome.

Good day again sir!
Is there a way for me to be able to show a save as prompt to save as the report.xlsx in the DataCompare folder so it wont be populated and will remain as a template?

Also, how can I remove the data rows of File2 in the Report.xlsx file when it has no match? so that it just exists on the last part of the column?

Thank you!!!!

Quote from royUK

You need to create a proper template with the extension .xltm. These files cannot be overwritten and you save a workbook created from them

How to use Excel Templates

so from this line;

Workbooks.Open ThisWorkbook.Path & "\" & "DATACOMPARE\Report.xlsx"

I will just make a xltm file and change it to;

Workbooks.Open ThisWorkbook.Path & "\" & "DATACOMPARE\Report.xltm"

am i right sir?

Quote from dietherdeyv

so from this line;

Workbooks.Open ThisWorkbook.Path & "\" & "DATACOMPARE\Report.xlsx"

I will just make a xltm file and change it to;

Workbooks.Open ThisWorkbook.Path & "\" & "DATACOMPARE\Report.xltm"

am i right sir?

Display More

This will work fine for me sir royUK

Can you help me with my other problem sir? huhu

I want to remove the rows from the right side data that has no MATCH and NO MATCH values

Quote from Mumps

The macro could save the report.xlsx workbook using a different name, perhaps by adding the date to the name.

Are you saying you want to delete the rows with blank cells in column K?

Yes sir. It is just like cutting the data with no match and then paste it below leaving its place blank

Quote from Mumps

Try:

Code

Sub Button1_Click()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, LastRow As Long, arr1 As Variant, arr2 As Variant, Val As String, rngList As Object
    Workbooks.Open ThisWorkbook.Path & "\" & "Report.xlsx"
    Set desWS = Sheets(1)
    Workbooks.Open ThisWorkbook.Path & "\" & "File1.xlsx"
    With Sheets(1)
        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        .Range("B1:E" & LastRow).Copy
        desWS.Range("B1").PasteSpecial Paste:=xlPasteValues
    End With
    Application.CutCopyMode = False
    Workbooks("File1.xlsx").Close False
    Workbooks.Open ThisWorkbook.Path & "\" & "File2.xlsx"
    With Sheets(1)
        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        .Range("B1:E" & LastRow).Copy
        desWS.Range("G1").PasteSpecial Paste:=xlPasteValues
    End With
    Application.CutCopyMode = False
    Workbooks("File2.xlsx").Close False
    arr1 = Range("B2", Range("B" & Rows.Count).End(xlUp)).Resize(, 4).Value
    arr2 = Range("G2", desWS.Range("G" & Rows.Count).End(xlUp)).Resize(, 4).Value
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
    Set rngList = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(arr1, 1)
        Val = arr1(i, 1) & "|" & arr1(i, 2) & "|" & arr1(i, 3) & "|" & arr1(i, 4)
        If Not rngList.Exists(Val) Then
            rngList.Add Val, Nothing
        End If
    Next i
    For i = 1 To UBound(arr2, 1)
        Val = arr2(i, 1) & "|" & arr2(i, 2) & "|" & arr2(i, 3) & "|" & arr2(i, 4)
        If rngList.Exists(Val) Then
            With desWS.Range("K" & i + 1)
                .Value = "MATCH"
                .Interior.ColorIndex = 4
            End With
        Else
            desWS.Range("G" & LastRow).Resize(, 4) = Array(arr2(i, 1), arr2(i, 2), arr2(i, 3), arr2(i, 4))
            With desWS.Range("K" & LastRow)
                .Value = "NO MATCH"
                .Interior.ColorIndex = 3
            End With
            LastRow = LastRow + 1
        End If
    Next i
    With desWS
        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        .Range("K2:K" & LastRow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End With
    Application.ScreenUpdating = True
End Sub

Display More

Is it possible sir that it won't delete the entire row?

Just the row starting from G to J?

Quote from Mumps

Try:

Code

Sub Button1_Click()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, LastRow As Long, arr1 As Variant, arr2 As Variant, Val As String, rngList As Object
    Workbooks.Open ThisWorkbook.Path & "\" & "Report.xlsx"
    Set desWS = Sheets(1)
    Workbooks.Open ThisWorkbook.Path & "\" & "File1.xlsx"
    With Sheets(1)
        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        .Range("B1:E" & LastRow).Copy
        desWS.Range("B1").PasteSpecial Paste:=xlPasteValues
    End With
    Application.CutCopyMode = False
    Workbooks("File1.xlsx").Close False
    Workbooks.Open ThisWorkbook.Path & "\" & "File2.xlsx"
    With Sheets(1)
        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        .Range("B1:E" & LastRow).Copy
        desWS.Range("G1").PasteSpecial Paste:=xlPasteValues
    End With
    Application.CutCopyMode = False
    Workbooks("File2.xlsx").Close False
    arr1 = Range("B2", Range("B" & Rows.Count).End(xlUp)).Resize(, 4).Value
    arr2 = Range("G2", desWS.Range("G" & Rows.Count).End(xlUp)).Resize(, 4).Value
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
    Set rngList = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(arr1, 1)
        Val = arr1(i, 1) & "|" & arr1(i, 2) & "|" & arr1(i, 3) & "|" & arr1(i, 4)
        If Not rngList.Exists(Val) Then
            rngList.Add Val, Nothing
        End If
    Next i
    For i = 1 To UBound(arr2, 1)
        Val = arr2(i, 1) & "|" & arr2(i, 2) & "|" & arr2(i, 3) & "|" & arr2(i, 4)
        If rngList.Exists(Val) Then
            With desWS.Range("K" & i + 1)
                .Value = "MATCH"
                .Interior.ColorIndex = 4
            End With
        Else
            desWS.Range("G" & LastRow).Resize(, 4) = Array(arr2(i, 1), arr2(i, 2), arr2(i, 3), arr2(i, 4))
            With desWS.Range("K" & LastRow)
                .Value = "NO MATCH"
                .Interior.ColorIndex = 3
            End With
            LastRow = LastRow + 1
        End If
    Next i
    With desWS
        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        .Range("K2:K" & LastRow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End With
    Application.ScreenUpdating = True
End Sub

Display More

I wanted it to look like this but I cannot find a way to code it. Please help

Quote from Mumps

Try:

Code

Sub Button1_Click()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, LastRow As Long, arr1 As Variant, arr2 As Variant, Val As String, rngList As Object, x As Long
    Workbooks.Open ThisWorkbook.Path & "\" & "Report.xlsx"
    Set desWS = Sheets(1)
    Workbooks.Open ThisWorkbook.Path & "\" & "File1.xlsx"
    With Sheets(1)
        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        .Range("B1:E" & LastRow).Copy
        desWS.Range("B1").PasteSpecial Paste:=xlPasteValues
    End With
    Application.CutCopyMode = False
    Workbooks("File1.xlsx").Close False
    Workbooks.Open ThisWorkbook.Path & "\" & "File2.xlsx"
    With Sheets(1)
        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        .Range("B1:E" & LastRow).Copy
        desWS.Range("G1").PasteSpecial Paste:=xlPasteValues
    End With
    Application.CutCopyMode = False
    Workbooks("File2.xlsx").Close False
    arr1 = Range("B2", Range("B" & Rows.Count).End(xlUp)).Resize(, 4).Value
    arr2 = Range("G2", desWS.Range("G" & Rows.Count).End(xlUp)).Resize(, 4).Value
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
    Set rngList = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(arr1, 1)
        Val = arr1(i, 1) & "|" & arr1(i, 2) & "|" & arr1(i, 3) & "|" & arr1(i, 4)
        If Not rngList.Exists(Val) Then
            rngList.Add Val, Nothing
        End If
    Next i
    For i = 1 To UBound(arr2, 1)
        Val = arr2(i, 1) & "|" & arr2(i, 2) & "|" & arr2(i, 3) & "|" & arr2(i, 4)
        If rngList.Exists(Val) Then
            With desWS.Range("K" & i + 1)
                .Value = "MATCH"
                .Interior.ColorIndex = 4
            End With
        Else
            desWS.Range("G" & LastRow).Resize(, 4) = Array(arr2(i, 1), arr2(i, 2), arr2(i, 3), arr2(i, 4))
            With desWS.Range("K" & LastRow)
                .Value = "NO MATCH"
                .Interior.ColorIndex = 3
            End With
            LastRow = LastRow + 1
        End If
    Next i
    With desWS
        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        For x = LastRow To 2 Step -1
            If Cells(x, 11) = "" Then
                Range("G" & x).Resize(, 5).Delete shift:=xlUp
            End If
        Next x
    End With
    Application.ScreenUpdating = True
End Sub

Display More

This is a nice work!!! But I really want to make my data look like this:

Oh I did it with this;

Range("G" & x).Resize(, 5).Delete shift = none

Thank you Mumps