比較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

您可以使用值數組來過濾范圍，剪切過濾范圍並將其移動到另一個工作表。 BUt這種模式更容易實現。

• 使用Collection來存儲要匹配的值
• 迭代要匹配的行注意：刪除/剪切時始終將最后一個元素轉到第一個元素
• 使用Entirerow.Cut目的地：=目的地剪切/移動匹配行

---

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