For Loop takes too long to execute

Question

What I am trying:
If in sheet1 and sheet2 there are cells with the same value on column E from sheet1 and column F from sheet2,
then copy the value from sheet2 column A row x to sheet2 column P row y.

Rows x and y are where the identical values are on each sheet.

Sub ccopiazanrfact()

Dim camion As Worksheet
Dim facturi As Worksheet
Set camion = ThisWorkbook.Sheets("B816RUS")
Set facturi = ThisWorkbook.Sheets("EVIDENTA FACTURI")

Dim nrcomanda As String
Dim nrfactura As String

For a = 2 To facturi.Range("F" & Rows.Count).End(xlUp).Row
    nrcomanda = facturi.Range("F" & a).Value
        
    For b = 4 To camion.Range("E" & Rows.Count).End(xlUp).Row
        If camion.Range("E" & b).Value = facturi.Range("F" & a).Value Then
            camion.Range("P" & b) = facturi.Range("A" & a).Value
            Exit For
        End If
    Next b

Next a
End Sub

Answer 1

in the end, I came up with this and works instantly, get’s all the data filled within a blink of an eye. When I tried it first time I thought i forgot to clear the data before running the code:

Sub FindMatchingValues()

  'Declare variables for the worksheets
  Dim ws1 As Worksheet
  Dim ws2 As Worksheet
  
  'Set the variables to refer to the worksheets
  Set ws1 = Worksheets("B816RUS")
  Set ws2 = Worksheets("EVIDENTA FACTURI")
  
  'Declare variables for the ranges to compare
  Dim rng1 As Range
  Dim rng2 As Range
  
  'Set the ranges to the columns to compare
  Set rng1 = ws1.Range("E1", ws1.Range("E" & Rows.Count).End(xlUp))
  Set rng2 = ws2.Range("F1", ws2.Range("F" & Rows.Count).End(xlUp))
  
  'Loop through each cell in the first range
  For Each cell1 In rng1
  
    'Use the Match function to find the matching value in the second range
    Dim match As Variant
    match = Application.match(cell1.Value, rng2, 0)
    
    'If a match was found, copy the value from column A in the second worksheet to column P in the first worksheet
    If Not IsError(match) Then
      ws1.Range("P" & cell1.Row).Value = ws2.Range("A" & match).Value
    End If
    
  Next cell1

End Sub

Answer 2

A VBA Lookup: Using Arrays and a Dictionary

Option Explicit

Sub CopiazaNrFact()
    
    Dim wb As Workbook: Set wb = ThisWorkbook

    ' Write the values from the Source Compare and Value ranges to arrays.
    
    ' f - Facturi (Source), c - Compare, v - Value
    
    Dim frg As Range, fcData() As Variant, fvData() As Variant, frCont As Long
    
    With wb.Sheets("EVIDENTA FACTURI")
        ' Compare
        Set frg = .Range("F2", .Cells(.Rows.Count, "F").End(xlUp))
        frCont = frg.Rows.Count
        fcData = frg.Value ' write to array
        ' Value
        Set frg = frg.EntireRow.Columns("A")
        fvData = frg.Value ' write to array
    End With
    
    ' Write the unique values from the Source Compare array to the 'keys',
    ' and their associated values from the Source Values array to the 'items'
    ' of a dictionary.
    
    Dim fDict As Object: Set fDict = CreateObject("Scripting.Dictionary")
    fDict.CompareMode = vbTextCompare
    
    Dim fr As Long, NrFacturi As String
    
    For fr = 1 To frCont
        NrFacturi = CStr(fcData(fr, 1))
        If Len(NrFacturi) > 0 Then ' exclude blanks
            fDict(NrFacturi) = fvData(fr, 1)
        End If
    Next fr
    
    ' Write the values from the Destination Compare range to an array
    ' and define the resulting same-sized Destination Value array.
    
    ' c - Camion (Destination), c - Compare, v - Value
    
    Dim crg As Range, ccData() As Variant, cvData() As Variant, crCont As Long
    
    With wb.Sheets("B816RUS")
        ' Compare
        Set crg = .Range("E4", .Cells(.Rows.Count, "E").End(xlUp))
        crCont = crg.Rows.Count
        ccData = crg.Value ' write to array
        ' Value
        Set crg = crg.EntireRow.Columns("P")
        ReDim cvData(1 To crCont, 1 To 1) ' define
    End With
    
    ' For each value in the Destination Compare array, attempt to find
    ' a match in the 'keys' of the dictionary, and write the associated 'item'
    ' to the same row of the Destination Value array.
    
    Dim cr As Long, NrCamion As String
    
    For cr = 1 To crCont
        NrCamion = CStr(ccData(cr, 1))
        If fDict.Exists(NrCamion) Then cvData(cr, 1) = fDict(NrCamion)
    Next cr

    ' Write the values from the Destination Value array
    ' to the Destination Value range.
    
    crg.Value = cvData

End Sub

Answer 3

Please, test the next code. It should be very fast, using arrays and Find function:

Sub ccopiazaNrfact()
    Dim camion As Worksheet, facturi As Worksheet, cellMatch As Range, rngE As Range
    Set camion = ThisWorkbook.Sheets("B816RUS")
    Set facturi = ThisWorkbook.Sheets("EVIDENTA FACTURI")
    
    Set rngE = camion.Range("E4:E" & camion.Range("E" & camion.rows.count).End(xlUp).row)
    Dim a As Long, arrFact, arrP, nrComanda As String
    
    arrP = camion.Range("P1:P" & camion.Range("E" & rows.count).End(xlUp).row).Value
    arrFact = facturi.Range("A2:F" & facturi.Range("F" & rows.count).End(xlUp).row).Value
    Debug.Print UBound(arrP): Stop
    For a = 1 To UBound(arrFact)
        nrComanda = arrFact(a, 6)
        Set cellMatch = rngE.Find(What:=nrComanda, After:=rngE.cells(1, 1), LookIn:=xlValues, lookAt:=xlWhole)
             
        If Not cellMatch Is Nothing Then
            arrP(cellMatch.row, 1) = arrFact(a, 1)
        End If
    Next a
    
    camion.Range("P1").Resize(UBound(arrP), 1).Value = arrP
    MsgBox "Ready..."
 End Sub

Please, send some feedback after testing it...

Answer 4

I would recommend using arrays to achieve what you want. Nested looping over ranges can make it very slow. Is this what you are trying? (UNTESTED). As I have not tested it, I would recommend making a backup of your data before you test this code.

I have commented the code. But if you still have a question or find an error/bug in the below code then simply ask.

Option Explicit

Sub ccopiazanrfact()
    Dim Camion As Worksheet
    Dim Facturi As Worksheet
    
    Set Camion = ThisWorkbook.Sheets("B816RUS")
    Set Facturi = ThisWorkbook.Sheets("EVIDENTA FACTURI")
    
    '~~> Declare 2 arrays
    Dim ArCamion As Variant
    Dim ArFacturi As Variant
    Dim LRow As Long
    
    '~~> Find last row in Col E of Sheets("B816RUS")
    LRow = Camion.Range("E" & Camion.Rows.Count).End(xlUp).Row
    '~~> Store Values from E4:P last row in the array. We have taken E:P
    '~~> because we are replacing the value in P if match found
    ArCamion = Camion.Range("E4:P" & LRow).Value
    
    '~~> Find last row in Col E of Sheets("EVIDENTA FACTURI")
    LRow = ArFacturi.Range("F" & ArFacturi.Rows.Count).End(xlUp).Row
    '~~> Store Values from A2:F last row in the array. We have taken A:F
    '~~> because we are replacing the value in P with A
    ArFacturi = Facturi.Range("A2:F" & LRow).Value
    
    Dim i As Long, j As Long
    
    For i = 2 To UBound(ArFacturi)
        For j = 4 To UBound(ArCamion)
            '~~> Checking if camion.Range("E" & j) = facturi.Range("F" & i)
            If ArCamion(j, 1) = ArFacturi(i, 6) Then
                '~~> Replacing camion.Range("P" & j) with facturi.Range("A" & i)
                ArCamion(j, 12) = ArFacturi(i, 1)
                Exit For
            End If
        Next j
    Next i

    '~~> Write the array back to the worksheet in one go
    Camion.Range("E4:P" & LRow).Resize(UBound(ArCamion), 12).Value = ArCamion
End Sub