[英]Search for a match, copy entire row, and paste to corresponding
“Sheet2”上的 Col B 包含 370 行数据。 从“Sheet2”单元格 B1 开始,我想在“Sheet1”上的 Col B 中搜索匹配值(它可能位于“Sheet1”Col B 的前 300 行中的任何位置)。 如果找到匹配项,则从“Sheet1”复制整行并粘贴到“Sheet2”上的 Row1。 然后,移动到“Sheet2”单元格 B2 并重复搜索,这次将整个行从“Sheet1”粘贴到“Sheet2”上的 Row2。 继续遍历“Sheet2”上的整个数据列,在“Sheet1”上搜索每个单元格的值。 如果搜索未返回匹配项,则不要将任何内容粘贴到“Sheet2”上的该行,然后继续搜索“Sheet2”上的下一个单元格。 (例如,如果 Sheet1 Col B 不包含 Sheet2 Cell B3 的匹配项,则不会在 Sheet2 Row3 中粘贴任何内容。)
我找到了以下示例,它开始对我有所帮助,但它指定了搜索值,并且不会像我试图做的那样遍历整个值列。
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
这应该可以解决问题,并且可以快速完成:
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
搜索匹配的单元格Union
创建找到的行的集合Union
不为空,请立即复制您的范围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.