我建议使用数组来实现你想要的。在范围内嵌套循环会使其非常慢。这就是你要尝试的吗？（未经测试）。由于我没有测试过它，我建议在测试此代码之前备份数据。
我已经注解了代码。但是如果你仍然有问题或者在下面的代码中发现了错误，那么就直接问吧。

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

字符串

最后，我想出了这个，并立即工作，得到的所有数据填充在一眨眼的功夫。当我第一次尝试它时，我以为我忘记在运行代码之前清除数据：

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

字符串

请测试下一个代码。它应该非常快，使用数组和Find函数：

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

字符串
请在测试后发送一些反馈…

VBA查询：使用数组和字典

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

字符串