我有两个包含信息的工作表，我想比较每个工作表的一列中的值，如果值相同，那么我想复制与新工作表相对应的整行。我目前正在使用For Next循环，但是运行非常耗时。有谁知道更快的方法来完成相同的任务？
'compares results and copies entire row with like results to new page
Sheets(2).Select
LR2 = 0
LR2 = Cells(Rows.Count, 1).End(xlUp).Row
Sheets(3).Select
LR3 = 0
LR3 = Cells(Rows.Count, 1).End(xlUp).Row
Sheets(2).Select
x = 2
For I = 2 To LR2
CellVal = Cells(x,3).Value
Sheets(3).Select
xx = 2
For ii = 2 To LR3
CellVal2 = Cells(xx,3).Value
If CellVal = CellVal2 Then
Rows(xx).Copy
Sheets(1).Select
LR1 = 0
LR1 = Cells(Rows.Count, 1),End(xlUp).Row
Cells(LR1 + 1, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues
Selection.NumberFormat = "0"
Selection.Columns.AutoFit
End If
xx = xx + 1
Next ii
x = x + 1
Next i
答案 0 :(得分：1)
我认为您可以修改并使用以下内容：
Option Explicit
Sub test()
Dim Lastrow1 As Long, Lastrow2 As Long, Lastrow3 As Long, i As Long
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim str As String
Dim rng As Range
'Set Worksheet' Variables
With ThisWorkbook
Set ws1 = .Worksheets("Sheet1")
Set ws2 = .Worksheets("Sheet2")
Set ws3 = .Worksheets("Sheet3")
End With
'Clear Sheet3
ws3.UsedRange.Clear
'Find Lastrow of Sheet1 & Sheet2
Lastrow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
Lastrow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
'Loop Sheet1, Column A
For i = 1 To Lastrow1
'Set str. It's the value in Sheet1, Column A & Row i
str = ws1.Range("A" & i).Value
'Use Find Method to check if str apperas in Sheet2, Column A
Set rng = ws2.Range("A1:A" & Lastrow2).Find(str)
'If rng in not nothing - Empty (means that str found in sheet2, column A
If Not rng Is Nothing Then
'Find lastrow of Sheet3, Column A
Lastrow3 = ws3.Cells(ws3.Rows.Count, "A").End(xlUp).Row
'Copy from Sheet1, Column A & row rng.row to Sheet3, Column A Lastrow3 + 1
ws1.Cells(rng.Row, 1).Copy ws3.Cells(Lastrow3 + 1, 1)
End If
Next i
End Sub
答案 1 :(得分：0)
您将必须调整工作表名称以适合您的名称。现在可以根据代码中的索引对它们进行调整：Sheet(1)是"Sheet1" ...
使用索引非常棘手，因此建议您远离索引。
比较不同工作表上两列的值，找到匹配项后，将该行从一个（指定）工作表复制到第三工作表。
要匹配的列被复制到两个数组。然后，通过遍历数组，将匹配项的行号写入第3个数组。然后将源工作表的“已用范围”复制到第4个数组。然后，通过遍历第3个数组（行号），将第4个数组（范围）中的每一行复制到第5个数组中，然后将其复制到目标工作表中。
Sub MatchCopyPaste()
Const cTgt As String = "Sheet1" ' Target Worksheet Name
Const cChk As String = "Sheet2" ' Check Worksheet Name
Const cSrc As String = "Sheet3" ' Source Worksheet Name
Const cFR As Long = 2 ' First Row
Const cLURC As Long = 1 ' Last-Used-Row Column
Const cCrit As Long = 3 ' Criteria Column
Dim rng As Range ' Last Used Cell of Ranges, Ranges
Dim vntSC As Variant ' Source-Column Array
Dim vntCC As Variant ' Check-Column Array
Dim vntTR As Variant ' Target-Rows Array
Dim vntS As Variant ' Source Array
Dim vntT As Variant ' Target Array
Dim SRC As Long ' Source Rows Count
Dim CRC As Long ' Check Rows Count
Dim TRC As Long ' Target Rows Count
Dim STCC As Long ' Source/Target Columns Count
Dim i As Long ' Source-Column Array Row Counter
' Target-Rows Array Row (Element) Counter,
' Target Array Row Counter
Dim j As Long ' Source/Target Array Column Counter
Dim k As Long ' Check-Column Array Row Counter
' Speed up.
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
' Handle Errors.
'On Error GoTo ErrorHandler
' In Last-Used-Row Column (cLURC) of Source Worksheet (cSrc)
With ThisWorkbook.Worksheets(cSrc).Columns(cLURC)
' Create a reference to the Last Used Cell (rng).
Set rng = .Find("*", , xlFormulas, , xlByColumns, xlPrevious)
' Calculate Source Rows Count (SRC).
SRC = rng.Row - cFR + 1
' Create a reference to Source-Column Range (rng) calculated from First
' Cell (.Cells(cFR, cCrit)), rows resized by Source Rows Count (SRC).
Set rng = .Parent.Cells(cFR, cCrit).Resize(SRC)
' Copy Source-Column Range (rng) to 2D 1-based 1-column Source-Column
' Array (vntSC).
vntSC = rng
End With
' In Last-Used-Row Column (cLURC) of Check Worksheet (cChk)
With ThisWorkbook.Worksheets(cChk).Columns(cLURC)
' Create a reference to the Last Used Cell (rng).
Set rng = .Find("*", , xlFormulas, , xlByColumns, xlPrevious)
' Calculate Check Rows Count (CRC).
CRC = rng.Row - cFR + 1
' Create a reference to Check-Column Range (rng) calculated from First
' Cell (.Cells(cFR, cCrit)), rows resized by Check Rows Count (CRC).
Set rng = .Parent.Cells(cFR, cCrit).Resize(CRC)
' Copy Check-Column Range (rng) to 2D 1-based 1-column Check-Column
' Array (vntCC).
vntCC = rng
End With
' Resize 1D 1-based Target-Rows Array (vntTR) to number of elements (rows)
' equal to Source Rows Count (SRC), because it cannot have more elements
' (rows). Later it will be down-sized (Redim).
' Remarks:
' In a 2D array, "rows" are the first dimension which cannot be resized.
' Target-Rows Array is chosen to be 1D, because only the last dimension
' of an array can be resized i.e. the first, last and only dimension
' will be elements (rows).
' Note: It can be done with a 2D array by writing to the 2nd dimension,
' "columns", which would be acceptable even a "must" if it later had
' to copied to a range (using Transpose).
ReDim vntTR(1 To SRC)
'**********************************************************
' Since you are writing data from Source-Column Range you wouldn't want
' to check values in Check-Column Range that aren't in Source-Column Range
' and you would probably want the order of found rows sorted by the
' found rows in Source-Column Range, not in Check-Column Range.
' If I'm wrong, outcomment these two lines and uncomment the corresponding
' lines below, which represent you original loop.
'**********************************************************
' Loop through rows (i) of Source-Column Array.
For i = 1 To SRC
' Loop through rows (k) of Check-Column Array.
For k = 1 To CRC
'**********************************************************
' ' Loop through rows (k) of Check-Column Array.
' For k = 1 To CRC
' ' Loop through rows (i) of Source-Column Array.
' For i = 1 To SRC
'**********************************************************
' Check current value of Check-Column Array (vntCC) against
' current value of Source-Columns Array (vntSC).
If vntSC(i, 1) = vntCC(k, 1) Then ' Matching found.
' Increase Target Row Counter (TRC) by 1 i.e. count the number
' of elements (rows) in Target-Rows Array (vntTR).
TRC = TRC + 1
' Write current row number (i) of Source-Column Array (vntSC)
' to current element (row) (TRC) of Target-Rows Array (vntTR).
vntTR(TRC) = i
'**********************************************************
' If you want to find only the first occurrence of a match,
' even better, if you know there is only one occurrence (i.e.
' Check-Column Range contains unique values), you
' will want to stop looping to increase efficiency i.e.
' you have to uncomment the following line.
'**********************************************************
' ' Match found. Stop looping in rows (k) of Check-Column Array
' ' (vntCC). Go to next row (i) of Source-Column Array (vntSC).
' Exit For
'**********************************************************
End If
Next
Next
' Resize (down-size) Target-Rows Array (vntTR) to number of elements (rows)
' equal to Target Rows Count (TRC).
ReDim Preserve vntTR(1 To TRC)
' In Source Worksheet
With ThisWorkbook.Worksheets(cSrc)
' Calculate Source/Target Columns Count (STCC) which in this case (not
' always) is equal to the Last Used Column in Source Range, because the
' copying later, is done from first column (1, because entire rows).
STCC = .Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
' Create a reference to Source Range (rng) calculated from First Cell
' (.Cells(cFR, cCrit)), rows resized by Source Rows Count (SRC),
' and columns resized by Source/Target Columns Count (STCC).
Set rng = .Cells(cFR, 1).Resize(SRC, STCC)
' Copy Source Range (rng) to 2D 1-based multi-column Source Array
' (vntS).
vntS = rng
End With
' Resize 2D 1-based multi-column Target Array (vntT) to Target Rows Count
' (TRC) for the 1st dimension (rows), and to Source/Target Columns Count
' (STCC) for the 2nd dimension (columns).
ReDim vntT(1 To TRC, 1 To STCC)
' Loop through elements (rows) (i) of Target-Rows Array (vntTR)
For i = 1 To TRC
' Loop through columns (j) of Source Array (vntS).
For j = 1 To STCC
' Write from Source Array (vntS), the value in the row which number
' is taken from current element (row) (i) of Target-Rows Array
' (vntTR), to current row of Target Array (vntT), both in current
' Source/Target Array Column (j).
' Note: The current element (row) (i) Target-Rows Array (vntTR) is equal
' to the current row (i) in Target Array (vntT).
vntT(i, j) = vntS(vntTR(i), j)
Next
Next
' In Last-Used-Row Column (cLURC) of Target Worksheet(cTgt).
With ThisWorkbook.Worksheets(cTgt).Columns(cLURC)
' Create a reference to the Last Used Cell.
Set rng = .Find("*", , xlFormulas, , xlByColumns, xlPrevious)
' Check if Last-Used-Row Column is not empty (Not ... Is Nothing).
If Not rng Is Nothing Then ' NOT empty. DOES contain data.
' Create a reference to Target Range (rng) calculated from the cell
' below (rng.Row + 1) the Last Used Cell in first column (1, because
' entire row) resized to the size (TRC, STCC)
' of Target Array (vntT).
Set rng = .Parent.Cells(rng.Row + 1, 1).Resize(TRC, STCC)
Else ' EMPTY. Does NOT contain data.
' Create a reference to Target Range (rng) calculated from the cell
' in First Row (cFR) in first column (1, because entire row) resized
' to the size (TRC, STCC) of Target Array (vntT).
Set rng = .Parent.Cells(cFR, 1).Resize(TRC, STCC)
End If
End With
' Copy Target Array (vntT) to Target Range (rng).
rng = vntT
' Apply formatting to Target Range (rng).
With rng
.NumberFormat = "0"
.Columns.AutoFit
End With
' Inform user that it is done.
MsgBox "The operation finished successfully.", vbInformation, "Success"
ProcedureExit:
' Speed down.
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
Exit Sub
ErrorHandler:
MsgBox "An unexpected error has occurred. Error '" & Err.Number & "': '" _
& Err.Description & "'", vbCritical, "Error"
GoTo ProcedureExit
End Sub
从技术上讲，该代码不会复制整个行，而只是将单元格的数据从A列复制到包含数据的最后一列（在工作表上）。如果有成千上万的列，那么可能存在内存问题，更不用说如果有成千上万的匹配项。