[英]Search for a match, copy entire row, and paste to corresponding
Col B on "Sheet2" contains 370 rows of data. “Sheet2”上的 Col B 包含 370 行数据。 Starting with "Sheet2" Cell B1, I want to search for a matching value in Col B on "Sheet1" (it could be located anywhere in the first 300 rows of "Sheet1" Col B).
从“Sheet2”单元格 B1 开始,我想在“Sheet1”上的 Col B 中搜索匹配值(它可能位于“Sheet1”Col B 的前 300 行中的任何位置)。 If a match is found, copy the entire row from "Sheet1" and paste to Row1 on "Sheet2".
如果找到匹配项,则从“Sheet1”复制整行并粘贴到“Sheet2”上的 Row1。 Then, move to "Sheet2" Cell B2 and repeat the search, this time pasting the entire row from "Sheet1" to Row2 on "Sheet2".
然后,移动到“Sheet2”单元格 B2 并重复搜索,这次将整个行从“Sheet1”粘贴到“Sheet2”上的 Row2。 Continue moving thru the entire column of data on "Sheet2", searching for each cell's value on "Sheet1".
继续遍历“Sheet2”上的整个数据列,在“Sheet1”上搜索每个单元格的值。 If a search doesn't return a match, then do not paste anything to that row on "Sheet2" and just proceed to search for the next cell on "Sheet2".
如果搜索未返回匹配项,则不要将任何内容粘贴到“Sheet2”上的该行,然后继续搜索“Sheet2”上的下一个单元格。 (For example, if Sheet1 Col B doesn't contain a match for Sheet2 Cell B3, then nothing gets pasted in Sheet2 Row3.)
(例如,如果 Sheet1 Col B 不包含 Sheet2 Cell B3 的匹配项,则不会在 Sheet2 Row3 中粘贴任何内容。)
I have found the following example, which starts to help me, but it specifies the search value and doesn't loop thru the entire column of values like I am attempting to do.我找到了以下示例,它开始对我有所帮助,但它指定了搜索值,并且不会像我试图做的那样遍历整个值列。
Sub CopyYes()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
' Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("Sheet1")
Set Target = ActiveWorkbook.Worksheets("Sheet2")
J = 1 ' Start copying to row 1 in target sheet
For Each c In Source.Range("E1:E1000") ' Do 1000 rows
If c = "yes" Then
Source.Rows(c.Row).Copy Target.Rows(j)
j = j + 1
End If
Next c
End Sub
This should do the trick, and do it fast:这应该可以解决问题,并且可以快速完成:
Option Explicit
Sub CopyYes()
'You need Microsoft Scripting Runtime library under Tools-References for this
Dim arrPaste As Variant: arrPaste = Sheet2.UsedRange.Value
Dim arrCopy As Variant: arrCopy = Sheet1.UsedRange.Value
Dim MyMatches As New Dictionary: Set MyMatches = CreateDictionary(arrCopy)
Dim i As Long
For i = 1 To UBound(arrPaste)
If arrPaste(i, 2) = vbNullString Then Exit For
If MyMatches.Exists(arrPaste(i, 2)) Then PasteData arrPaste, arrCopy, i, MyMatches(arrPaste(i, 2))
Next i
Sheet2.UsedRange.Value = arrPaste
Erase arrCopy
Erase arrPaste
End Sub
Private Function CreateDictionary(arr As Variant) As Dictionary
Dim i As Long
Set CreateDictionary = New Dictionary
For i = 1 To 300
CreateDictionary.Add arr(i, 2), i
Next i
End Function
Private Sub PasteData(arrPaste As Variant, arrCopy As Variant, i As Long, MyMatch As Long)
Dim j As Long
For j = 1 To UBound(arrCopy, 2)
If arrCopy(MyMatch, j) = vbNullString Then Exit For
arrPaste(i, j) = arrCopy(MyMatch, j)
Next j
End Sub
Range.Find
to search for your matching cellRange.Find
搜索匹配的单元格Union
to create a collection of the rows that are foundUnion
创建找到的行的集合Union
is not emptyUnion
不为空,请立即复制您的范围Sub Shelter_In_Place()
Dim Source As Worksheet: Set Source = ThisWorkbook.Sheets("Sheet1")
Dim Target As Worksheet: Set Target = ThisWorkbook.Sheets("Sheet2")
Dim Found As Range, lr As Long
Dim CopyMe As Range
lr = Target.Range("B" & Target.Rows.Count).End(xlUp).Row
For i = 1 To lr
Set Found = Source.Range("B:B").Find(Target.Range("B" & i), LookIn:=xlWhole)
If Not Found Is Nothing Then
If Not CopyMe Is Nothing Then
Set CopyMe = Union(CopyMe, Target.Range("B" & i))
Else
Set CopyMe = Target.Range("B" & i)
End If
End If
Set Fouund = Nothing
Next i
If Not CopyMe Is Nothing Then
CopyMe.EntireRow.Copy
Source.Range("A1").PasteSpecial xlPasteValues
End If
End Sub
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.