VBA Code to add lines by comparing to workbooks

[Balajibenz]

Hi People,

Can someone help me with below requirement.

I have two workbooks(Wk1 and Wk2) with same headers and data. now i want to compare WK1(latest data) with WK2(old data) and add the lines of data to WK1 which is present in WK2 but not in WK1. to compare I can use column A in both sheets where I have a ID which is unique number. I am looking for VBA code that compared Column A WK1(sheet1) with column A of WK2(sheet2) and anything not present in WK1 but present in WK2 should be copied(entire line from A to X) and pasted in sheet1 of WK1 in first empty row. thank you in advance.

 

[JLGWhiz]

See if you can use this: You might have to tweak the workbook names where I used the index numbers.

Sub t()
Dim sh1 As Worksheet, sh2 As Worksheet, c As Range
Set sh1 = Workbooks(1).Sheets(1)
Set sh2 = Workbooks(2).Sheets(1)
    For Each c In sh2.Range("A2", sh2.Cells(Rows.Count, 1).End(xlUp))
        If Application.CountIf(sh1.Range("A:A"), c.Value) = 0 Then
            c.Resize(, 24).Copy sh1.Cells(Rows.Count, 1).End(xlUp)(2)
        End If
    Next
End Sub

 

[Balajibenz]

See if you can use this: You might have to tweak the workbook names where I used the index numbers.

Sub t()
Dim sh1 As Worksheet, sh2 As Worksheet, c As Range
Set sh1 = Workbooks(1).Sheets(1)
Set sh2 = Workbooks(2).Sheets(1)
    For Each c In sh2.Range("A2", sh2.Cells(Rows.Count, 1).End(xlUp))
        If Application.CountIf(sh1.Range("A:A"), c.Value) = 0 Then
            c.Resize(, 24).Copy sh1.Cells(Rows.Count, 1).End(xlUp)(2)
        End If
    Next
End Sub

Hi Mate,

Thank you, it is working perfectly but my data has around 60k lines hence once code is run it is going in to not responding mode and taking around 10 min to complete. Is there anything you can help on this further. Thank you so much again.

 

[JLGWhiz]

You can try this. It turns a couple of things off that add to the time and then turns them badk on after your copying is done.

Sub t()
Dim sh1 As Worksheet, sh2 As Worksheet, c As Range
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Set sh1 = Workbooks(1).Sheets(1)
Set sh2 = Workbooks(2).Sheets(1)
    For Each c In sh2.Range("A2", sh2.Cells(Rows.Count, 1).End(xlUp))
        If Application.CountIf(sh1.Range("A:A"), c.Value) = 0 Then
            c.Resize(, 24).Copy sh1.Cells(Rows.Count, 1).End(xlUp)(2)
        End If
    Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

 

[Balajibenz]

You can try this. It turns a couple of things off that add to the time and then turns them badk on after your copying is done.

Sub t()
Dim sh1 As Worksheet, sh2 As Worksheet, c As Range
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Set sh1 = Workbooks(1).Sheets(1)
Set sh2 = Workbooks(2).Sheets(1)
    For Each c In sh2.Range("A2", sh2.Cells(Rows.Count, 1).End(xlUp))
        If Application.CountIf(sh1.Range("A:A"), c.Value) = 0 Then
            c.Resize(, 24).Copy sh1.Cells(Rows.Count, 1).End(xlUp)(2)
        End If
    Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Hi Mate,

I have them already in my code and it still takes around 10 min to finish this part alone.

 

[Fluff]

How about

Sub Balajibenz()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, c As Long, nr As Long
   Dim Dic As Object
   
   Set Dic = CreateObject("scripting.dictionary")
   With Workbooks("wk1.xlsm").Sheets("sheet1")
      Ary = .Range("A2", .Range("A" & Rows.count).End(xlUp)).Value2
   End With
   For r = 1 To UBound(Ary)
      Dic(Ary(r, 1)) = ""
   Next r
   With Workbooks("wk2.xlsm").Sheets("sheet1")
      Ary = .Range("A2:X" & .Range("A" & Rows.count).End(xlUp).Row).Value2
   End With
   ReDim Nary(1 To UBound(Ary), 1 To UBound(Ary, 2))
   For r = 1 To UBound(Ary)
      If Not Dic.exists(Ary(r, 1)) Then
         nr = nr + 1
         For c = 1 To UBound(Ary, 2)
            Nary(nr, c) = Ary(r, c)
         Next c
      End If
   Next r
   With Workbooks("wk1.xlsm").Sheets("sheet1")
      .Range("A" & Rows.count).End(xlUp).Offset(1).Resize(nr, UBound(Nary, 2)).Value = Nary
   End With
End Sub

 

[JLGWhiz]

See if this runs any faster.

Sub t2()
Dim sh1 As Worksheet, sh2 As Worksheet, c As Range, fn As Range
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Set sh1 = Workbooks(1).Sheets(1)
Set sh2 = Workbooks(2).Sheets(1)
    For Each c In sh2.Range("A2", sh2.Cells(Rows.Count, 1).End(xlUp))
        Set fn = sh1.Range("A:A").Find(c.Value, , xlValues, xlWhole)
            If fn Is Nothing Then
                c.Resize(, 24).Copy sh1.Cells(Rows.Count, 1).End(xlUp)(2)
            End If
    Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

I see that @Fluff has offered code using dictionary. That should speed it up.

 

[Balajibenz]

How about

Sub Balajibenz()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, c As Long, nr As Long
   Dim Dic As Object
  
   Set Dic = CreateObject("scripting.dictionary")
   With Workbooks("wk1.xlsm").Sheets("sheet1")
      Ary = .Range("A2", .Range("A" & Rows.count).End(xlUp)).Value2
   End With
   For r = 1 To UBound(Ary)
      Dic(Ary(r, 1)) = ""
   Next r
   With Workbooks("wk2.xlsm").Sheets("sheet1")
      Ary = .Range("A2:X" & .Range("A" & Rows.count).End(xlUp).Row).Value2
   End With
   ReDim Nary(1 To UBound(Ary), 1 To UBound(Ary, 2))
   For r = 1 To UBound(Ary)
      If Not Dic.exists(Ary(r, 1)) Then
         nr = nr + 1
         For c = 1 To UBound(Ary, 2)
            Nary(nr, c) = Ary(r, c)
         Next c
      End If
   Next r
   With Workbooks("wk1.xlsm").Sheets("sheet1")
      .Range("A" & Rows.count).End(xlUp).Offset(1).Resize(nr, UBound(Nary, 2)).Value = Nary
   End With
End Sub

Hi Fluff, that works wonders. it is doing the job in matter of seconds. thank you so much. while pasting the lines format is not being pasted as the data has dates in it. can you help with that alone.

 

[Fluff]

On this part change Value2 to Value

   With Workbooks("wk2.xlsm").Sheets("sheet1")
      Ary = .Range("A2:X" & .Range("A" & Rows.count).End(xlUp).Row).Value2
   End With