对于循环，当在两张图纸之间找到匹配项时，复制整行

Question

我正在尝试获得一个For循环，如果ws1中C列的单元格和ws2中AT列的单元格匹配，该循环将整行从工作表1复制到工作表3。我有两个问题：1.它似乎卡在For i=xxxxx循环中，没有移动到下一个k（只复制一行25次）2.当我在工作表1有100000行、工作表2有15000行的工作表上使用它时，excel就会崩溃。有办法解决这个问题吗？

Sub CopyBetweenWorksheets()
Application.ScreenUpdating = False
Dim i As Long, k As Long, ws1 As Worksheet, ws2 As Worksheet, myVar As String, myVar2 As String
Set ws1 = Worksheets("BOM")
Set ws2 = Worksheets("APT")
Set ws3 = Worksheets("Combined")
'get the last row for w2 and w1
ii = ws1.Cells.SpecialCells(xlCellTypeLastCell).row
kk = ws2.Cells.SpecialCells(xlCellTypeLastCell).row
For k = 2 To kk
    myVar = ws2.Cells(k, 46)
For i = 688 To ii   '688 To ii
    myVar2 = ws1.Cells(i, 3)
    If myVar2 = myVar Then
        ws3.Rows(k).EntireRow.Value = ws1.Rows(i).EntireRow.Value 'copy entire row
      Exit For
       End If
    Next i
Next k
End Sub

Answer 1

您的代码很好（没有提到缺少的Application.ScreenUpdating = True），但由于与应用程序（本例中为Excel）的交互量很大，它将挂在大量的行和列上。

每次从Excel中的单个单元格请求值时，每100万个请求中，代码将挂起约4秒。对于整行，它将每4000个请求挂起4秒。如果你尝试写一个单元格，你的代码每175000个请求将挂起4秒，而写一整行将每300个请求挂起4秒钟。

这样，只有当您尝试将15000行数据从一张表解析到另一张表时，您的代码才会挂起约3.3分钟。。更不用说所有的读取请求了。。

因此，即使您必须创建更大的代码，也要始终将与vba中任何应用程序的交互量保持在最低限度。

如果你想处理大量数据，下面是你的代码应该是什么样子的：

Sub CopyBetweenWorksheets2()
Dim aAPT, aBOM, aCombined As Variant
Dim lLastRow As Long, lLastColumn As Long
Dim i As Long, j As Long
Const APTColRef = 3
Const BOMColRef = 46
Const MAXCol = 200
'Speed up VBA in Excel
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Get the last row and column to use with the combined sheet
lLastRow = WorksheetFunction.Min(APT.Cells.SpecialCells(xlCellTypeLastCell).Row, BOM.Cells.SpecialCells(xlCellTypeLastCell).Row)
lLastColumn = WorksheetFunction.Min(MAXCol, WorksheetFunction.Max(APT.Cells.SpecialCells(xlCellTypeLastCell).Column, BOM.Cells.SpecialCells(xlCellTypeLastCell).Column))
'Parse all values to an array, reducing interactions with the application
aAPT = Range(APT.Cells(1), APT.Cells(lLastRow, lLastColumn))
aBOM = Range(BOM.Cells(1), BOM.Cells(lLastRow, lLastColumn))
'Creates a temporary array with the values to parse to the destination sheet
ReDim aCombined(1 To lLastRow, 1 To lLastColumn)
'Loop trough values and parse the row value if true
For i = 1 To lLastRow
If aAPT(i, APTColRef) = aBOM(i, BOMColRef) Then
    For j = 1 To lLastColumn
        aCombined(i, j) = aAPT(i, j)
    Next
End If
Next
'Parse values from the destination array to the combined sheet
Combined.Range(Combined.Cells(1), Combined.Cells(lLastRow, lLastColumn)) = aCombined
'Disable tweaks
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationManual
End Sub

我在VBA中为图纸对象命名，这样您就不必声明新变量，而且以后重命名它们也不会有任何问题。所以，代替表单（"APT"），我只是使用了APT（如果你想让代码工作，你也必须重命名它）！！

另外，这是我为测试代码而写的速度代码。我总是把它放在手边，并在我写的几乎每一个功能中使用它

Sub Speed()
Dim i As Long
Dim dSec As Double
Dim Timer0#
Dim TimerS#
Dim TimerA#
Dim TimerB#
dSec = 4 ''Target time in secounds''
i = 1
WP1:
Timer0 = Timer
For n = 1 To i
SpeedTestA
Next
TimerA = Timer
For n = 1 To i
SpeedTestB
Next
TimerB = Timer
If TimerB - Timer0 < dSec Then
    If TimerB - Timer0 <> 0 Then
        i = CLng(i * (dSec * 2 / (TimerB - Timer0)))
        GoTo WP1
    Else
        i = i * 100
        GoTo WP1
    End If
End If
MsgBox "Código A: " & TimerA - Timer0 & vbNewLine & "Código B: " & TimerB - TimerA & vbNewLine & "Iterações: " & i
End Sub
Sub SpeedTestA() 'Fist Code
End Sub
Sub SpeedTestB() 'Secound Code
End Sub