VBA code to import data, doing lookups to detect duplicates

Question

I have an import macro, which creates ID by concatenating cells, then I compare using VLOOKUP with another sheet if any duplicate found.

It's running very slowly, so I want to know better ways to optimize this code, because once finished, I will need to add another "for" for to handle duplicates found and compare dates.

It's one of my first macros in VBA, so I'm sure there are a lot of ways to improve the performance.

Sub ImportData()
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim slr As Long
Dim dlr As Long
Dim Tlr As Long
Set wb1 = ActiveWorkbook
FileToOpen = Application.GetOpenFilename _
(Title:="Select import file", _
FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm")
If FileToOpen = False Then
 MsgBox "No File Specified.", vbExclamation, "ERROR"
 Exit Sub
Else
 Set wb2 = Workbooks.Open(Filename:=FileToOpen)
 slr = wb2.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
 wb2.Worksheets("Sheet1").Range("A8:S" & slr).Copy _
 wb1.Worksheets("INPUT_DATA").Range("A2")
End If
 wb2.Close savechanges:=False
 dlr = wb1.Worksheets("INPUT_DATA").Cells(Rows.Count, 1).End(xlUp).Row
 wb1.Worksheets("INPUT_DATA").Range("A2:S" & dlr).ClearFormats
 For cell = 2 To dlr
 Cells(cell, 20).Formula = "=CONCAT(RC[-19], ""__"",RC[-18])"
 Next
 'check duplicate values before import to TOTAL_DATA
 Tlr = wb1.Worksheets("TOTAL_DATA").Cells(Rows.Count, 1).End(xlUp).Row
 countMatch = 0
 countUnmatch = 0
 For cell = 2 To dlr
 Cells(cell, 21).Formula = "=IF(ISNA(VLOOKUP(RC[-1],TOTAL_DATA!C30,1,FALSE)), ""No"", ""Yes"")"
 If Cells(cell, 21).Value = "Yes" Then
 Cells(cell, 20).Font.Color = vbRed
 countMatch = countMatch + 1
 Else
 Range("A" & cell, "T" & cell).Cut Destination:=wb1.Worksheets("TOTAL_DATA").Range("A" & Tlr + 1)
 Tlr = Tlr + 1
 countUnmatch = countUnmatch + 1
 End If
 Next cell
 If countMatch > 0 Then
 MsgBox "Found duplicates!!" & vbCr & "Number of duplicates : " & countMatch & _
 vbCr & "Duplicate items were keep at INPUT_DATA" & vbCr & _
 "Loaded succesfully : " & countUnmatch & " items", vbExclamation
 Else
 MsgBox "Loaded succesfully : " & countUnmatch & " items"
 End If
End Sub
```

• Eleutery: Thanks @200_success for you edit, next question i'll try to do much better! ;)

Answer 1

This should be twice as fast:

dlr = wb1.Worksheets("INPUT_DATA").Cells(Rows.Count, 1).End(xlUp).Row
wb1.Worksheets("INPUT_DATA").Range("A2:S" & dlr).ClearFormats
'check duplicate values before import to TOTAL_DATA
 Tlr = wb1.Worksheets("TOTAL_DATA").Cells(Rows.Count, 1).End(xlUp).Row
 countMatch = 0
 countUnmatch = 0
For cell = 2 To dlr
 Cells(cell, 20).Formula = "=CONCAT(RC[-19], ""__"",RC[-18])"
 Cells(cell, 21).Formula = "=IF(ISNA(VLOOKUP(RC[-1],TOTAL_DATA!C30,1,FALSE)), ""No"", ""Yes"")"
 If Cells(cell, 21).Value = "Yes" Then
 Cells(cell, 20).Font.Color = vbRed
 countMatch = countMatch + 1
 Else
 Range("A" & cell, "T" & cell).Cut Destination:=wb1.Worksheets("TOTAL_DATA").Range("A" & Tlr + 1)
 Tlr = Tlr + 1
 countUnmatch = countUnmatch + 1
 End If
Next cell

Because in here we loop only once from 2 to dlr.

Answer 2

This is not a full answer, but it should lead you to the right way:

Option Explicit
Sub ImportData()
 Dim wb2 As Workbook
 Dim ws1 As Worksheet 'you can also reference sheets
 Dim ws2 As Worksheet
 Dim slr As Long
 Dim dlr As Long
 Dim Tlr As Long
 Dim arrData 'working with arrays is always better
 Dim i As Long
 Dim DictDuplicates As New Scripting.Dictionary 'You need Microsoft Scripting Runtime for this to work
 'I'm gonna assume you don't have/want formulas on the INPUT_DATA so it will be all values.
 With ThisWorkbook 'always better ThisWorkbook if its the same containing the code
 Set ws1 = .Sheets("INPUT_DATA")
 Set ws2 = .Sheets("TOTAL_DATA")
 End With
 'Lets Store the lookup data in a dictionary so you can check it later
 With ws2
 dlr = .Cells(.Rows.Count, 30).End(xlUp).Row
 For i = 2 To dlr ' I'm assuming the data has headers, if not, change 2 for 1
 'This may throw an error if your data is duplicated on that sheet
 DictDuplicates.Add .Cells(i, 30), i 'store the value and it's position for later needs
 Next i
 End With
 FileToOpen = Application.GetOpenFilename _
 (Title:="Select import file", _
 FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm")
 If FileToOpen = False Then
 MsgBox "No File Specified.", vbExclamation, "ERROR"
 Exit Sub
 Else
 Set wb2 = Workbooks.Open(Filename:=FileToOpen, ReadOnly:=True) 'since you are not writting, open it on ReadOnly to avoid problems
 With wb2.Worksheets("Sheet1")
 slr = .Cells(.Rows.Count, 1).End(xlUp).Row 'You didn't qualified the Rows.Count
 arrData = .Range("A8:S" & slr).Value
 End With
 wb2.Close savechanges:=False
 End If
 'Now you can work on the array
 For i = 2 To UBound(arrData) ' I'm assuming the data copied has headers, if not, change 2 for 1
 If DictDuplicates.Exists(arrData(i, 1) & """__""" & arrData(i, 2)) Then
 'If the concatenated data exists on the dictionary
 Else
 'If it doesn't
 End If
 Next i
 With ws1
 .Range(.Cells(1, 1), .Cells(UBound(arrData), UBound(arrData, 2))).Value = arrData 'paste the array to the worksheet
 End With
End Sub

Think of using arrays/dictionaries when working with large amounts of data.