Match Copy Paste
Вам нужно будет настроить имена рабочих листов в соответствии с вашими.Теперь они корректируются, поскольку у вас есть индексы в вашем коде: Sheet(1) - это "Sheet1" ... Использование индексов довольно сложно, поэтому я рекомендую вам держаться подальше от него.
Что
Сравнивает значения двух столбцов на разных листах и, когда совпадение найдено, копирует строку из одного (указанного) листа в третий лист.
Как (Не совсем верно)
Сопоставимые столбцы копируются в два массива.Затем, просматривая массивы, номера строк совпадений записываются в третий массив.Затем «используемый диапазон» исходного листа копируется в 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 в последний столбец, содержащий данные (на листе).Если есть тысячи столбцов, может возникнуть проблема с памятью, не говоря уже о десятках тысяч совпадений.