For循环执行时间太长

Question

我正在尝试:
如果在sheet1和sheet2中有相同值的单元格在列E来自sheet1和列F来自sheet2，
然后从sheet2列A行x复制值到sheet2列p行y。

行x和y是每个工作表上相同的值。

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

我建议使用数组来实现您想要的效果。在范围内嵌套循环会使它非常慢。这就是你想要的吗?(未经考验的)。由于我还没有测试过它，我建议在测试这段代码之前对数据进行备份。

我已经注释了代码。但是，如果您仍然有问题或发现以下代码中的错误/bug，请直接询问。

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

Answer 2

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

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 3

请测试下一个代码。它应该非常快，使用数组和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

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

Answer 4

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