Code for working double loop working but very slow : Better way?

Question

I'm fairly new to VBA, and I've written a piece of code that is technicly working, however it takes ages, and I'm fairly sure a more elegant solution is possible.

What I'm trying to do : 1 main Excel database exists (Sheets "Doc1"). Every week a new bunch data is sent (sheetsDoc3), with a few new lines added randomly among the old data (can't change that).

I needed to find a solution to check for each row of the new data if it was already in the main database or not. If it is, nothing happens, else copy/paste at the end of the Main database the row in question.

I used 2 For loop to achieve that result, but since those are 2000 rows long sheets, it almost kills the computer which is a basic notebook.

Below is the existing code, and I'm open to suggestions to better it :

    Sub Copypaste()

Dim NotFound As Boolean, LNCHR As Integer, Ligne As Integer, NBVAL As Integer

'NBCL is the number of rows in Doc 3
'NBTR is the number of rows in DOC 1
'NBVAL is the number of value in DOC1


NBCL = WorksheetFunction.CountA(Sheets("Doc3").Range("F:F"))
NBTR = WorksheetFunction.CountA(Sheets("Doc1").Range("I:I"))
NBVAL = WorksheetFunction.CountA(Sheets("Doc1").Range("I:I")) + 1

For LNCHR = 2 To NBCL
 For Ligne = 2 To NBTR
 
NBVAL = WorksheetFunction.CountA(Sheets("Doc1").Range("I:I")) + 1

  If Sheets("Doc3").Cells(LNCHR, 1) Like Sheets("Doc1").Cells(Ligne, 1) _
  And Sheets("Doc3").Cells(LNCHR, 2) Like Sheets("Doc1").Cells(Ligne, 2) _
  And Sheets("Doc3").Cells(LNCHR, 3) Like Sheets("Doc1").Cells(Ligne, 3) _
  And Sheets("Doc3").Cells(LNCHR, 4) Like Sheets("Doc1").Cells(Ligne, 4) _
  And Sheets("Doc3").Cells(LNCHR, 5) Like Sheets("Doc1").Cells(Ligne, 5) _
  And Sheets("Doc3").Cells(LNCHR, 6) Like Sheets("Doc1").Cells(Ligne, 6) _
  And Sheets("Doc3").Cells(LNCHR, 7) Like Sheets("Doc1").Cells(Ligne, 7) _
  And Sheets("Doc3").Cells(LNCHR, 8) Like Sheets("Doc1").Cells(Ligne, 8) _
  And Sheets("Doc3").Cells(LNCHR, 9) Like Sheets("Doc1").Cells(Ligne, 9) _
  Then
  Else
  NotFound = True
  End If

Next Ligne
  
  If NotFound = True Then
    Sheets("Doc1").Cells(NBVAL, 1) = Sheets("Doc3").Cells(LNCHR, 1)
    Sheets("Doc1").Cells(NBVAL, 2) = Sheets("Doc3").Cells(LNCHR, 2)
    Sheets("Doc1").Cells(NBVAL, 3) = Sheets("Doc3").Cells(LNCHR, 3)
    Sheets("Doc1").Cells(NBVAL, 4) = Sheets("Doc3").Cells(LNCHR, 4)
    Sheets("Doc1").Cells(NBVAL, 5) = Sheets("Doc3").Cells(LNCHR, 5)
    Sheets("Doc1").Cells(NBVAL, 6) = Sheets("Doc3").Cells(LNCHR, 6)
    Sheets("Doc1").Cells(NBVAL, 7) = Sheets("Doc3").Cells(LNCHR, 7)
    Sheets("Doc1").Cells(NBVAL, 8) = Sheets("Doc3").Cells(LNCHR, 8)
    Sheets("Doc1").Cells(NBVAL, 9) = Sheets("Doc3").Cells(LNCHR, 9)
    NBVAL = NBVAL + 1
    End If
Next LNCHR
  
End Sub

Answer 1

Using RemoveDuplicates

• It is assumed that the data (tables: one row of headers) starts with cell A1 on both worksheets.
• It will copy the data from Doc3 to Doc1 and remove duplicated rows.
• I'm not sure how this will behave with many rows hence your feedback is appreciated.

Option Explicit

Sub copyRemoveDuplicates()
    
    ' Constants
    Const dName As String = "Doc1"
    Const sName As String = "Doc3"
    Const Cols As String = "A:I"
    
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Destination
    
    ' Destination Columns Range
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dcrg As Range: Set dcrg = dws.Columns(Cols)
    
    ' Columns Array (For 'RemoveDuplicates').
    Dim cUpper As Long: cUpper = dcrg.Columns.Count - 1
    Dim ColsArray As Variant: ReDim ColsArray(0 To cUpper)
    Dim n As Long
    For n = 0 To cUpper
        ColsArray(n) = n + 1
    Next n
    
    ' Destination Last Non-Empty Cell
    Dim dlCell As Range
    Set dlCell = dcrg.Find("*", , xlFormulas, , xlByRows, xlPrevious)
    If dlCell Is Nothing Then Exit Sub
    
    ' Destination First Empty Row (Range)
    Dim derg As Range: Set derg = dcrg.Rows(dlCell.Row).Offset(1)
    
    ' Source
    
    ' Source Range
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    ' Use another way if this doesn't work for your data.
    Dim srg As Range
    With sws.Range("A1").CurrentRegion
        Set srg = .Columns(Cols).Resize(.Rows.Count - 1).Offset(1)
    End With
    
    ' Copy / Remove Duplicates
    
    Application.ScreenUpdating = False
    
    ' Copy
    srg.Copy derg
    
    ' Destination Range (after copying Source Range)
    Dim drg As Range
    Set drg = dcrg.Resize(dlCell.Row + srg.Rows.Count)
    
    ' Remove Duplicates
    drg.RemoveDuplicates (ColsArray), xlYes

    Application.ScreenUpdating = True

End Sub