Excel VBA search id and import data from other sheet - excel

Question

I'm working on a project with lots of data in two different sheets which is want to combine.
For example:
My Sheet1 should contain 4 columns. Columns 1 and 2 are already filled with ID's and a status.
In Sheet2 I have 3 columns. The first contains the ID's again, the second a serial-number and the third a Yes/No.
The two sheets have around 5500 rows in it. The first a little more then the second.
I would like to run a loop which picks the first ID in Sheet1, checks if it exists in Sheet2, and if it does, it should copy the two missing columns (serial-number and Yes/No) into into Sheet1.
Then the to the next Id in Sheet1 and do the same again.
I tried it with the code below, but I'm not getting it to work.
Hope you can help me out!
Dim i As Long
Dim Found As Range
For i = 1 To Rows.Count
Worksheets("Sheet1").Activate
If Cells(i, 1).Value <> "" Then
Set Found = Worksheets("Sheet2").Range("A2", Range("A")).Find(i, 1)
If Not Found Is Nothing Then
Worksheets("Sheet1").Range(i, 3).Value = Cells(Found.Row, 2).Value
Worksheets("Sheet1").Range(i, 4).Value = Cells(Found.Row, 3).Value
End If
End If
Next i

Answer 1

You could try with two nested for each loops.
Sub copySerial()
Dim range1 As Range, range2 As Range
Set range1 = Worksheets("Sheet1").Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
Set range2 = Worksheets("Sheet2").Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
For Each c1 In range1
For Each c2 In range2
If c1.Value = c2.Value Then
c1.Offset(0, 2).Value = c2.Offset(0, 1).Value
c1.Offset(0, 3).Value = c2.Offset(0, 2).Value
End If
Next c2
Next c1
End Sub

Answer 2

Arrays Before Ranges
Adjust the values in the constants section to fit your needs. Do it
carefully (slowly) because there are many.
First I created the second code which appeared to be super slow.
After implementing arrays, it got 30 times faster at 5000 records. I guess the extra work pays off.
Option Explicit
Sub UpdateSheetArray() ' Calculates for about 3s at 5000 records - Acceptable!
Const strSrc As String = "Sheet2" ' Source Worksheet Name
Const frSrc As Long = 2 ' Source First Row Number
Const colSrc As Long = 1 ' Source Compare Column Number
Const colSrc1 As Long = 2 ' Source Data Column 1
Const colSrc2 As Long = 3 ' Source Data Column 2
Const strTgt As String = "Sheet1" ' Target Worksheet Name
Const frTgt As Long = 1 ' Target First Row Number
Const colTgt As Long = 1 ' Target Compare Column Number
Const colTgt1 As Long = 3 ' Target Data Column 1
Const colTgt2 As Long = 4 ' Target Data Column 2
Dim wsSrc As Worksheet ' Source Worksheet
Dim wsTgt As Worksheet ' Target Worksheet
Dim vntSrc As Variant ' Source Compare Array
Dim vntSrc1 As Variant ' Source Data Array 1
Dim vntSrc2 As Variant ' Source Data Array 2
Dim vntTgt As Variant ' Target Compare Array
Dim vntTgt1 As Variant ' Target Data Array 1
Dim vntTgt2 As Variant ' Target Data Array 2
Dim rngSrc As Range ' Source Compare Range,
' Source Data Range 1,
' Source Data Range 2
Dim rngTgt As Range ' Target Compare Range,
' Target Data Range 1,
' Target Data Range 2
Dim lrSrc As Long ' Source Last Non-Empty Row Number
Dim lrTgt As Long ' Target Last Non-Empty Row Number
Dim varCur As Variant ' Current Target Cell Value
Dim i As Long ' Source Row Counter
Dim j As Long ' Target Row Counter
' Define Source and Target Worksheets.
Set wsSrc = Worksheets(strSrc)
Set wsTgt = Worksheets(strTgt)
' Calculate Last Non-Empty Row in Source Worksheet.
lrSrc = wsSrc.Columns(colSrc).Find(What:="*", LookIn:=xlFormulas, _
SearchDirection:=xlPrevious).Row
' Calculate Last Non-Empty Row in Target Worksheet.
lrTgt = wsTgt.Columns(colTgt).Find(What:="*", LookIn:=xlFormulas, _
SearchDirection:=xlPrevious).Row
' Define Source Compare Range and write its values to Source Compare Array.
Set rngSrc = wsSrc.Cells(frSrc, colSrc).Resize(lrSrc - frSrc + 1)
vntSrc = rngSrc
' Define Source Data Range 1 and write its values to Source Data Array 1.
Set rngSrc = rngSrc.Offset(, colSrc1 - colSrc): vntSrc1 = rngSrc
' Define Source Data Range 2 and write its values to Source Data Array 2.
Set rngSrc = rngSrc.Offset(, colSrc2 - colSrc1): vntSrc2 = rngSrc
' Define Target Compare Range and write its values to Target Compare Array.
Set rngTgt = wsTgt.Cells(frTgt, colTgt).Resize(lrTgt - frTgt + 1)
vntTgt = rngTgt
' Define Target Data Arrays (same size as Target Compare Array).
ReDim vntTgt1(1 To UBound(vntTgt), 1 To 1)
ReDim vntTgt2(1 To UBound(vntTgt), 1 To 1)
' Note: These last two arrays are going to be written to,
' while the previous four are going to be read from.
' All arrays are 2-dimensional 1-based 1-column arrays.
' Loop through elements of Target Compare Array.
For i = 1 To UBound(vntTgt)
' Write value of current element in Target Array
' to Current Target Cell Value.
varCur = vntTgt(i, 1)
' Check if Current Target Cell Value is not "".
If varCur <> "" Then
' Loop through elements of Source Compare Array.
For j = 1 To UBound(vntSrc)
' Check if value of current element in Source Array is equal
' to Current Target Cell Value.
If vntSrc(j, 1) = varCur Then
' Write current elements in Source Data Arrays
' to Target Data Arrays.
vntTgt1(i, 1) = vntSrc1(j, 1): vntTgt2(i, 1) = vntSrc2(j, 1)
' No need to loop anymore after found.
Exit For
End If
Next
End If
Next
' Define Target Data Range 1.
Set rngTgt = rngTgt.Offset(, colTgt1 - colTgt)
' Write values of Target Data Array 1 to Target Data Range 1.
rngTgt = vntTgt1
' Define Target Data Range 2.
Set rngTgt = rngTgt.Offset(, colTgt2 - colTgt1)
' Write values of Target Data Array 2 to Target Data Range 2.
rngTgt = vntTgt2
End Sub
Sub UpdateSheetRange() ' Calculates for about 90s at 5000 records - too slow!
Const strSrc As String = "Sheet2" ' Source Worksheet Name
Const frSrc As Long = 2 ' Source First Row Number
Const colSrc As Long = 1 ' Source Compare Column Number
Const colSrc1 As Long = 2 ' Source Data Column 1
Const colSrc2 As Long = 3 ' Source Data Column 2
Const strTgt As String = "Sheet1" ' Target Worksheet Name
Const frTgt As Long = 1 ' Target First Row Number
Const colTgt As Long = 1 ' Target Compare Column Number
Const colTgt1 As Long = 3 ' Target Data Column 1
Const colTgt2 As Long = 4 ' Target Data Column 2
Dim wsSrc As Worksheet ' Source Worksheet
Dim wsTgt As Worksheet ' Target Worksheet
Dim lrSrc As Long ' Source Last Non-Empty Row Number
Dim lrTgt As Long ' Target Last Non-Empty Row Number
Dim varCur As Variant ' Current Target Cell Value
Dim i As Long ' Source Row Counter
Dim j As Long ' Target Row Counter
' Define Worksheet.
Set wsSrc = Worksheets(strSrc)
Set wsTgt = Worksheets(strTgt)
' Calculate Last Non-Empty Row in Source Worksheet.
lrSrc = wsSrc.Columns(colSrc).Find(What:="*", LookIn:=xlFormulas, _
SearchDirection:=xlPrevious).Row
' Calculate Last Non-Empty Row in Target Worksheet.
lrTgt = wsTgt.Columns(colTgt).Find(What:="*", LookIn:=xlFormulas, _
SearchDirection:=xlPrevious).Row
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
On Error GoTo ProgramError
For i = frTgt To lrTgt
varCur = wsTgt.Cells(i, colTgt).Value
If varCur <> "" Then
For j = frSrc To lrSrc
If wsSrc.Cells(j, colSrc).Value = varCur Then
wsTgt.Cells(i, colTgt1) = wsSrc.Cells(j, colSrc1).Value
wsTgt.Cells(i, colTgt2) = wsSrc.Cells(j, colSrc2).Value
Exit For
End If
Next
End If
Next
SafeExit:
With Application
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
Exit Sub
ProgramError:
MsgBox "An unexpected error occurred."
On Error GoTo 0
GoTo SafeExit
End Sub