excel - Copy data from one sheet and search in different sheet

Question

Good day, can anyone help me? i am trying to use VBA to copy data and search to another sheet. I have 2 sheets, 'Sheet1'(customer data) and 'raw data'. Sheet1 contains thousand rows which are unique records, while raw data have 400 rows where it contains duplication. I have to merge these 2 sheets and copying customer unique records and find in raw data (inclusive of duplication). i tried using For loop but it is making the program slow as it needs to loop thousand times.

appreciate your help and guidance.

Sub Test2()
Dim last1, last2 As Long
Dim x, y As Integer


 Sheets("Sheet1").Select
 last1 = Worksheets("Sheet1").Range("J" & Rows.Count).End(xlUp).Row
 
 For x = 2 To last1
    Range("I" & x & ":K" & x).Select
    Application.CutCopyMode = False
    Selection.Copy
    Worksheets(2).Select
    Range("A" & x).Select
    ActiveSheet.Paste
    Sheets("Sheet1").Select
    Range("M" & x).Select
    Application.CutCopyMode = False
    Selection.Copy
    Worksheets(2).Select
    Range("D" & x).Select
    ActiveSheet.Paste
    
    Sheets("raw data").Select
    last2 = Worksheets("raw data").Range("G" & Rows.Count).End(xlUp).Row
    
        For y = 2 To last2
        If Worksheets(2).Range("B" & x).Value = Worksheets("raw data").Range("G" & y).Value Then
        Worksheets("raw data").Select
        Range("G" & y & ":J" & y).Select
        Selection.Copy
        Worksheets(2).Select
        
            If IsEmpty(Range("F" & x)) Then
        
            Range("F" & x).Select
            ActiveSheet.Paste
            Worksheets("raw data").Select
            Range("M" & y).Select
            Selection.Copy
            Worksheets(2).Select
            Range("E" & x).Select
            ActiveSheet.Paste
            
            Else
            
            x = x + 1
            Range("F" & x).Select
            ActiveSheet.Paste
            Worksheets("raw data").Select
            Range("M" & y).Select
            Selection.Copy
            Worksheets(2).Select
            Range("E" & x).Select
            ActiveSheet.Paste
            
            End If
            
        
        End If
        Next
    
    Sheets("Sheet1").Select
    
 Next

End Sub

question from:https://stackoverflow.com/questions/65878327/copy-data-from-one-sheet-and-search-in-different-sheet

Answer 1

As I understand it, you want to scan through the raw data records, check if the raw data record corresponds to an existing customer record. If it does, then you update the existing customer record. If it does not correspond to an existing customer record then you want to add a new customer record.

What slows down your approach is the repeated use of Select, Copy and Paste. Things will go much faster if you use variables. Read both sheets into variant arrays and then do the comparisons there as in the sample code below.

Option Explicit

Sub AddRecords()
    Dim vRaw As Variant
    Dim vCustomers As Variant
    Dim rgRaw As Range
    Dim rgCustomers As Range
    Dim lCustRow As Long, lCustCol As Long
    Dim lRawRow As Long, lRawCol As Long
    Dim blnFound As Boolean
    
    Set rgRaw = ActiveWorkbook.Worksheets("raw data").Cells(1, 1).CurrentRegion
    vRaw = rgRaw    ' Retrieve entire range of raw data
    Set rgCustomers = ActiveWorkbook.Worksheets("customers").Cells(1, 1).CurrentRegion
    vCustomers = rgCustomers    ' Retrieve entire range of customer data
    For lRawRow = 2 To UBound(vRaw, 1) ' Go through each row in the raw data
        blnFound = False
        For lCustRow = 2 To UBound(vCustomers, 1)   ' Compare raw row to each customer row
            If vCustomers(lCustRow, 2) = vRaw(lRawRow, 7) Then  ' Compare col B to col G as per your code
                blnFound = True
                Exit For
            End If
        Next lCustRow
        If blnFound Then
            ' Update the existing customer row
            ' I don't quite follow the logic of your code but something like the following is needed
            vCustomers(lCustRow, 3) = vRaw(lRawRow, 8)
            vCustomers(lCustRow, 4) = vRaw(lRawRow, 9)
        Else
            ' Expand the customer array to accommodate the new row
            lCustRow = UBound(vCustomers, 1) + 1
            ' VBA doesn't let you expand Redim Preserve anything but the last dimension of an array, _
            so expand it by manually
            vCustomers = RedimFirstDimension(vCustomers, lCustRow)
            ' Populate the new row in the customer array
            ' I don't quite follow the logic of your code but something like the following is needed
            vCustomers(lCustRow, 2) = vRaw(lRawRow, 7)
       End If
    Next
    ' Write the customer array back to the customers sheet
    ' Resize the range since you may have added new customers
    Set rgCustomers = rgCustomers.Resize(UBound(vCustomers, 1), UBound(vCustomers, 2))
    ' Copy back the updated array
    rgCustomers = vCustomers
End Sub

Function RedimFirstDimension(vArray As Variant, nrRows As Long) As Variant
    ' Change the first dimension of the array
    Dim lRow As Long
    Dim lCol As Long
    Dim vNew As Variant

    ReDim vNew(LBound(vArray, 1) To nrRows, LBound(vArray, 2) To UBound(vArray, 2))
    For lRow = LBound(vArray, 1) To UBound(vArray, 1)
        For lCol = LBound(vArray, 2) To UBound(vArray, 2)
            vNew(lRow, lCol) = vArray(lRow, lCol)
        Next lCol
    Next lRow
    RedimFirstDimension = vNew
End Function