我是新手，所以请帮助我。我有一张三张以下的工作簿 -
Sheet1-有3个cloumns-A，B，C Sheet2-有一列-A **输出继电器
如果 Sheet1- B列的单元格中的值与 Sheet2 A列的任何单元格中的值匹配，则复制整行并粘贴到下一个可用的空白行（从输出表的A）列开始。
表2的B列可以有重复的单元格，所有匹配的单元格应该转到下一个可用的输出表格行。
**Sheet 1** **Sheet 2** **Output**
A B C A 3 Glen 28
1 Jen 26 Glen 1 Jen 26
2 Ben 24 Jen 4 Jen 18
3 Glen 28
4 Jen 18
我在下面尝试过。不确定它有多好 -
Sub Test()
Set objwork1 = ActiveWorkbook ' Workbooks("Search WR")
Set obj1 = objwork1.Worksheets("Header")
Set obj2 = objwork1.Worksheets("XML1")
Set obj3 = objwork1.Worksheets("VC")
Set obj4 = objwork1.Worksheets("Output")
i = 2
j = 2
Do Until (obj3.Cells(j, 1)) = ""
If obj2.Cells(i, 2) = obj3.Cells(j, 1) Then
Set sourceColumn = obj2.Rows(i)
Set targetColumn = obj4.Rows(j)
sourceColumn.Copy Destination:=targetColumn
Else
i = i + 1
End If
j = j + 1
Loop
End Sub
也在下面尝试过 -
Sub Check()
Set objwork1 = ActiveWorkbook ' Workbooks("Search WR")
Set obj1 = objwork1.Worksheets("Header")
Set obj2 = objwork1.Worksheets("XML1")
Set obj3 = objwork1.Worksheets("VC")
Set obj4 = objwork1.Worksheets("Output")
Dim LR As Long, i As Long, j As Long
j = 2
LR = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LR
For j = 2 To LR
obj3.Select
If obj3.Range("A" & i).value = obj2.Range("B" & j).value Then
Rows(j).Select
Selection.Copy
obj4.Select
obj4.Range("A1").End(xlDown).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
obj3.Select
End If
Next j
Next i
End Sub
答案 0 :(得分：0)
类似的东西（假设你是从第一张纸上复制的。那不清楚）。
Option Explicit
Sub test()
Dim wb As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Set wb = ThisWorkbook
Set ws1 = wb.Worksheets("Sheet1")
Set ws2 = wb.Worksheets("Sheet2")
Set ws3 = wb.Worksheets("Output")
Dim currCell As Range, unionRng As Range
'Sheet1 column B matches sheet2 column A
With ws1
For Each currCell In Intersect(.Range("B:B"), .UsedRange)
If FoundInColumn(ws2, currCell, 1) Then
If Not unionRng Is Nothing Then
Set unionRng = Union(unionRng, currCell.EntireRow)
Else
Set unionRng = currCell.EntireRow
End If
End If
Next currCell
End With
If Not unionRng Is Nothing Then unionRng.Copy ws3.Range("A" & IIf(GetLastRow(ws3, 1) = 1, 1, GetLastRow(ws3, 1)))
End Sub
Public Function FoundInColumn(ByVal ws As Worksheet, ByVal findString As String, ByVal columnNo As Long) As Boolean
Dim foundCell As Range
Set foundCell = ws.Columns(columnNo).Find(What:=findString, After:=ws.Cells(1, columnNo), LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not foundCell Is Nothing Then FoundInColumn = True
End Function
Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
With ws
GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row
End With
End Function
如果是匹配到复制的sheet2的所有内容，那么：
Option Explicit
Sub test2()
Dim wb As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Set wb = ThisWorkbook
Set ws1 = wb.Worksheets("Sheet1")
Set ws2 = wb.Worksheets("Sheet2")
Set ws3 = wb.Worksheets("Output")
Dim currCell As Range, unionRng As Range
Dim dict As Dictionary 'tools > references > ms scripting runtime
Set dict = New Dictionary
'Sheet1 column B matches sheet2 column A
With ws1
For Each currCell In Intersect(.Range("B:B"), .UsedRange)
If Not dict.Exists(currCell.Value) And Not IsEmpty(currCell) Then
dict.Add currCell.Value, currCell.Value
Dim tempRng As Range
Set tempRng = GatherRanges(currCell.Value, Intersect(ws2.Range("A:A"), ws2.UsedRange))
If Not tempRng Is Nothing Then
If Not unionRng Is Nothing Then
Set unionRng = Union(unionRng, tempRng)
Else
Set unionRng = tempRng
End If
End If
End If
Next currCell
End With
If Not unionRng Is Nothing Then unionRng.EntireRow.Copy ws3.Range("A" & IIf(GetLastRow2(ws3, 1) = 1, 1, GetLastRow2(ws3, 1)))
End Sub
Public Function GatherRanges(ByVal findString As String, ByVal searchRng As Range) As Range
Dim foundCell As Range
Dim gatheredRange As Range
With searchRng
Set foundCell = searchRng.Find(findString)
Set gatheredRange = foundCell
Dim currMatch As Long
For currMatch = 1 To WorksheetFunction.CountIf(.Cells, findString)
Set foundCell = .Find(What:=findString, After:=foundCell, _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
If Not gatheredRange Is Nothing Then
Set gatheredRange = Union(gatheredRange, foundCell)
Else
Set gatheredRange = foundCell
End If
Next currMatch
End With
Set GatherRanges = gatheredRange
End Function
Public Function GetLastRow2(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
With ws
GetLastRow2 = .Cells(.Rows.Count, columnNumber).End(xlUp).Row
End With
End Function
答案 1 :(得分：0)
另一种方法
Sheet1复制到Output Output）Sheet2进行排序
Output中不在列表中的所有行（从最后一行开始）所以......
Option Explicit
Public Sub CopyListedRowsAndSortByListOrder()
Dim wsSrc As Worksheet
Set wsSrc = Worksheets("Sheet1")
Dim lRowSrc As Long
lRowSrc = wsSrc.Cells(wsSrc.Rows.Count, "A").End(xlUp).Row
Dim wsList As Worksheet
Set wsList = Worksheets("Sheet2")
Dim lRowList As Long
lRowList = wsList.Cells(wsList.Rows.Count, "A").End(xlUp).Row
Dim wsDest As Worksheet
Set wsDest = Worksheets("Output")
'Copy all rows
wsSrc.Range("A1:C" & lRowSrc).Copy wsDest.Range("A1")
Dim lRowDest As Long
lRowDest = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Row
'sort Output column B by list in Sheet2
With wsDest.Sort
.SortFields.Add Key:=wsDest.Range("B2:B" & lRowDest), _
SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _
Join(WorksheetFunction.Transpose(wsList.Range("A2:A" & lRowList).Value), ","), DataOption:=xlSortNormal
.SetRange Range("A1:C" & lRowDest)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'remove all rows not in list (backwards)
Dim i As Long
For i = lRowDest To 2 Step -1
If Not IsError(Application.Match(wsDest.Cells(i, "B"), wsList.Range("A2:A" & lRowList))) Then Exit For
Next i
wsDest.Range(i + 1 & ":" & lRowDest).Delete xlShiftUp
End Sub
答案 2 :(得分：0)
你可以试试这个
{{1}}