vba - 比较 sheet1 和 sheet2 中的单元格值，然后将整行移动到 sheet3

Question

我有三个工作表，例如 "Sheet1"、"Sheet2" 和 "Sheet3"。

"Sheet1" 有原始数据。在 "Sheet2" 中，我在 A 列中包含所有收到的付款数据和公司名称。我在 "Sheet1" 列 B 中有公司名称。

这里我要做的是，如果任何公司名称在 "Sheet1" 中匹配，我会在收到原始数据后立即将整行移动到 "Sheet3"。我也写了下面的代码，但是不能正常工作:

Sub RowFinder()
Dim sheet1Data As Variant

With Worksheets("Sheet2") '<--| reference your worksheet 2
    sheet1Data = Application.Transpose(.Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).Value)
End With
With Worksheets("Sheet1") '<--| reference your worksheet 1
    With .Range("B2", .Cells(.Rows.Count, "B").End(xlUp)) '<--| reference its column A cells from row 1 (header) down to last not empty one
        .AutoFilter field:=1, Criteria1:=sheet1Data, Operator:=xlFilterValues '<--| filter cells with sheet 2 column A values
        If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then Intersect(.Parent.UsedRange, .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).EntireRow).Copy Destination:=Worksheets("Sheet3").Range("A1")
    End With
    .AutoFilterMode = False
End With
End Sub

有人可以帮忙解决这个问题吗？谢谢。

---

这是完整的代码。

Sub Vlookup()

Windows("Contract Report v1.2.xlsm").Activate
Worksheets("Contract Details").Activate
Columns("A:C").Select
Selection.Copy
Windows("Contract Reports.xls").Activate
With ActiveWorkbook
    .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Sheet2"
End With
Worksheets("Sheet2").Activate
ActiveSheet.Paste
Application.CutCopyMode = False
Worksheets("Sheet1").Activate

' Column D = "SoW#"
lastRow = Range("B" & Rows.Count).End(xlUp).Row
Range("D2").FormulaR1C1 = "=VLOOKUP(RC[-2],Sheet2!C[-3]:C[-1],2,0)"
Range("D2").AutoFill Destination:=Range("D2:D" & lastRow), 
Type:=xlFillDefault
Sheets("Sheet1").Columns(4).Copy
Sheets("Sheet1").Columns(4).PasteSpecial xlPasteValues
Columns("D").Select
On Error Resume Next
Cells.Replace What:="#N/A", Replacement:="Not Yet Defined", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

' Column E = "Service Line"
lastRow = Range("B" & Rows.Count).End(xlUp).Row
Range("E2").FormulaR1C1 = "=VLOOKUP(RC[-3],Sheet2!C[-4]:C[-2],3,0)"
Range("E2").AutoFill Destination:=Range("E2:E" & lastRow), Type:=xlFillDefault
Sheets("Sheet1").Columns(5).Copy
Sheets("Sheet1").Columns(5).PasteSpecial xlPasteValues
Columns("E").Select
On Error Resume Next
Cells.Replace What:="#N/A", Replacement:="Not Yet Defined", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

Application.DisplayAlerts = False
Sheets("Sheet2").Delete
Application.DisplayAlerts = True
Worksheets("Sheet1").Activate

Columns("D:E").EntireColumn.AutoFit
Columns("D:E").HorizontalAlignment = xlCenter
Range("A1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$AQ$1").AutoFilter field:=12, Criteria1:="Yes"
Columns("D:E").EntireColumn.AutoFit
Columns("D:E").HorizontalAlignment = xlCenter

Range("A1:A10000") = Evaluate("IF(LEN(A1:A10000),A1:A10000,B1:B10000)")
Range("B:B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

ActiveWorkbook.Save

Application.ScreenUpdating = False

ColAry = Array("Owner's Email", "BFM Name", "Contract Currency4", "Contract Value4", "Contract Currency5", "Contract Value5")

With Sheets("Sheet1")
For z = LBound(ColAry) To UBound(ColAry)
fc = 0
On Error Resume Next
fc = Application.Match(ColAry(z), .Rows(1), 0)
On Error GoTo 0
If fc > 0 Then
  .Columns(fc).Delete
End If
Next z
End With

With Sheets("Sheet1")
Set SrchRng = ActiveSheet.Range("B2", ActiveSheet.Range("B65536").End(xlUp))
Do
    Set c = SrchRng.Find("A", LookIn:=xlValues)
    If Not c Is Nothing Then c.EntireRow.Delete
Loop While Not c Is Nothing
Range("A1").Select
End With

Application.ScreenUpdating = True
ActiveWorkbook.Save

'All the below mentioned contract id's will be shown as "Ignore" under status column.

With ActiveWorkbook
.Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Ignore"
End With

With ActiveWorkbook
.Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Sheet3"
End With

Windows("Contract Report v1.2.xlsm").Activate
Worksheets("Ignore").Activate
Columns("A").Copy
Windows("Contract Reports.xls").Activate
Worksheets("Ignore").Activate
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("A1").Select
Call Delrow
End Sub

Sub Delrow()

'--- The below code will move all the Ignore contract to another sheet ------

With Worksheets("Ignore") '<--| reference your worksheet 2
    sheet1Data = Application.Transpose(.Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).Value)
End With
With Worksheets("Sheet1") '<--| reference your worksheet 1
    With .Range("B2", .Cells(.Rows.Count, "B").End(xlUp)) '<--| reference its column A cells from row 1 (header) down to last not empty one
        .AutoFilter field:=1, Criteria1:=sheet1Data, Operator:=xlFilterValues '<--| filter cells with sheet 2 column A values
        If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then Intersect(.Parent.UsedRange, .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).EntireRow).Copy Destination:=Worksheets("Sheet3").Range("A1")
    End With
    .AutoFilterMode = False
End With
MsgBox "Done"
End Sub

Answer 1

您可以使用值数组来过滤范围，剪切过滤范围并将其移动到另一个工作表。但是这种模式更容易实现。

• 使用集合存储要匹配的值
• 迭代匹配的行注意:删除/剪切时总是从最后一个元素到第一个元素
• 使用 Entirerow.Cut Destination:=Destination 剪切/移动匹配行

---

Sub MatchValues()
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Dim c As Range, list As Object
    Dim r As Long
    Set list = CreateObject("System.Collections.ArrayList")

    With Worksheets("Sheet2")
        For Each c In .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
            If c.Value <> "" And Not list.Contains(c.Value) Then list.Add c.Value
        Next
    End With

    With Worksheets("Sheet1")
        For r = .Cells(.Rows.Count, "B").End(xlUp).Row To 2 Step -1
            If list.Contains(.Cells(r, "B").Value) Then
                MoveRow .Rows(r)
            End If
        Next
    End With
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Sub MoveRow(Target As Range)
    Dim lastow As Long
    With Worksheets("Sheet3").Cells
        If WorksheetFunction.CountA(.Cells) = 0 Then
            LastRow = 1 
        Else 
               lastRow = .Find(What:="*", After:=.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
        End If
        Target.EntireRow.Cut .Rows(lastRow + 1)
    End With

End Sub