根据另一个 sheet 中的匹配字段复制数据
Copy data against matching fields in another sheet
我正在尝试将数据从显示器 sheet 复制到具有 (176000) 行的账单 sheet 中的相关消费者,按照我发现的代码工作但它非常慢,执行一个条目大约需要 5 分钟.
Sub SAVERECOVERY()
For i = 5 To 125
If Cells(i, 20) > 0 Then
Sheets("Bills").Cells(Cells(i, 20), 24) = Sheets("Display").Cells(i, 5)
Sheets("Bills").Cells(Cells(i, 20), 25) = Sheets("Display").Cells(i, 7)
Sheets("Bills").Cells(Cells(i, 20), 26) = Sheets("Display").Cells(i, 9)
Sheets("Bills").Cells(Cells(i, 20), 27) = Sheets("Display").Cells(i, 11)
End If
Next
End Sub
显示sheet:
账单sheet:
请尝试下一个代码。它应该非常快。只需要设置要复制范围的行 (firstRow
, lastRow
) 并注意将要粘贴处理结果的(连续)行放在第 20 列中。在事实上,只写第一行就足够了:
Sub SAVERECOVERY()
Dim firstRow As Long, lastRow As Long, shB As Worksheet, shD As Worksheet
Dim arr24 As Variant, arr25 As Variant, arr26 As Variant, arr27 As Variant
Dim pasteRow As Long, i As Long, arrRows As Variant
Set shB = Sheets("Bills")
Set shD = Sheets("Display")
firstRow = 5: lastRow = 125: pasteRow = CLng(shD.cells(firstRow, 20))
arr24 = shD.Range(shD.cells(firstRow, 5), shD.cells(lastRow, 5)).value
arr25 = shD.Range(shD.cells(firstRow, 7), shD.cells(lastRow, 7)).value
arr26 = shD.Range(shD.cells(firstRow, 9), shD.cells(lastRow, 9)).value
arr27 = shD.Range(shD.cells(firstRow, 11), shD.cells(lastRow, 11)).value
arrRows = shD.Range(shD.cells(firstRow, 20), shD.cells(lastRow, 20)).value
Application.Calculation = xlCalculationManual
For i = 1 To UBound(arrRows)
If arr24(i, 1) <> "" Then shB.cells(CLng(arrRows(i, 1)), 24).value = arr24(i, 1)
If arr25(i, 1) <> "" Then shB.cells(CLng(arrRows(i, 1)), 25).value = arr25(i, 1)
If arr26(i, 1) <> "" Then shB.cells(CLng(arrRows(i, 1)), 26).value = arr26(i, 1)
If arr27(i, 1) <> "" Then shB.cells(CLng(arrRows(i, 1)), 27).value = arr27(i, 1)
Next i
Application.Calculation = xlCalculationAutomatic
shB.Activate: shB.cells(pasteRow, 24).Select
MsgBox "Ready..."
End Sub
Sub SAVERECOVERY()
For i = 5 To 125
If Cells(i, 20) > 0 Then
Sheets("Bills").Cells(Cells(i, 20), 24) = Sheets("Display").Cells(i, 5)
Sheets("Bills").Cells(Cells(i, 20), 25) = Sheets("Display").Cells(i, 7)
Sheets("Bills").Cells(Cells(i, 20), 26) = Sheets("Display").Cells(i, 9)
Sheets("Bills").Cells(Cells(i, 20), 27) = Sheets("Display").Cells(i, 11)
End If
Next
End Sub
显示sheet:
账单sheet:
请尝试下一个代码。它应该非常快。只需要设置要复制范围的行 (firstRow
, lastRow
) 并注意将要粘贴处理结果的(连续)行放在第 20 列中。在事实上,只写第一行就足够了:
Sub SAVERECOVERY()
Dim firstRow As Long, lastRow As Long, shB As Worksheet, shD As Worksheet
Dim arr24 As Variant, arr25 As Variant, arr26 As Variant, arr27 As Variant
Dim pasteRow As Long, i As Long, arrRows As Variant
Set shB = Sheets("Bills")
Set shD = Sheets("Display")
firstRow = 5: lastRow = 125: pasteRow = CLng(shD.cells(firstRow, 20))
arr24 = shD.Range(shD.cells(firstRow, 5), shD.cells(lastRow, 5)).value
arr25 = shD.Range(shD.cells(firstRow, 7), shD.cells(lastRow, 7)).value
arr26 = shD.Range(shD.cells(firstRow, 9), shD.cells(lastRow, 9)).value
arr27 = shD.Range(shD.cells(firstRow, 11), shD.cells(lastRow, 11)).value
arrRows = shD.Range(shD.cells(firstRow, 20), shD.cells(lastRow, 20)).value
Application.Calculation = xlCalculationManual
For i = 1 To UBound(arrRows)
If arr24(i, 1) <> "" Then shB.cells(CLng(arrRows(i, 1)), 24).value = arr24(i, 1)
If arr25(i, 1) <> "" Then shB.cells(CLng(arrRows(i, 1)), 25).value = arr25(i, 1)
If arr26(i, 1) <> "" Then shB.cells(CLng(arrRows(i, 1)), 26).value = arr26(i, 1)
If arr27(i, 1) <> "" Then shB.cells(CLng(arrRows(i, 1)), 27).value = arr27(i, 1)
Next i
Application.Calculation = xlCalculationAutomatic
shB.Activate: shB.cells(pasteRow, 24).Select
MsgBox "Ready..."
End Sub