VBA Code to add lines by comparing to workbooks

Balajibenz

Board Regular
Joined
Nov 18, 2020
Messages
56
Office Version
  1. 2013
Platform
  1. Windows
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.
 

Some videos you may like

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
12,979
Office Version
  1. 2013
Platform
  1. Windows
See if you can use this: You might have to tweak the workbook names where I used the index numbers.

VBA Code:
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

Board Regular
Joined
Nov 18, 2020
Messages
56
Office Version
  1. 2013
Platform
  1. Windows
See if you can use this: You might have to tweak the workbook names where I used the index numbers.

VBA Code:
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

Well-known Member
Joined
Feb 7, 2012
Messages
12,979
Office Version
  1. 2013
Platform
  1. Windows
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.

Rich (BB code):
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

Board Regular
Joined
Nov 18, 2020
Messages
56
Office Version
  1. 2013
Platform
  1. Windows

ADVERTISEMENT

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.

Rich (BB code):
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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
55,537
Office Version
  1. 365
Platform
  1. Windows
How about
VBA Code:
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
 
Solution

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
12,979
Office Version
  1. 2013
Platform
  1. Windows

ADVERTISEMENT

See if this runs any faster.

VBA Code:
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

Board Regular
Joined
Nov 18, 2020
Messages
56
Office Version
  1. 2013
Platform
  1. Windows
How about
VBA Code:
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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
55,537
Office Version
  1. 365
Platform
  1. Windows
On this part change Value2 to Value
VBA Code:
   With Workbooks("wk2.xlsm").Sheets("sheet1")
      Ary = .Range("A2:X" & .Range("A" & Rows.count).End(xlUp).Row).Value2
   End With
 

Watch MrExcel Video

Forum statistics

Threads
1,127,557
Messages
5,625,501
Members
416,114
Latest member
Ayush_123

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
Top