Excel VBA - For Loop IS taking far far too long to execute-CodePudding

First question ever here, I am the newbiest newbie..

So.. what I am trying to get is:

to find if in sheet1 and sheet2 there are cells with the same value on column E from sheet1 and column F from sheet2. if there are, 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.

this is my code:

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

CodePudding user response：

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

CodePudding user response：

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...