我有3张纸，例如"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
答案 0 :(得分：2)
您可以使用值数组来过滤范围，剪切过滤的范围并将其移动到另一张纸上。 BUt这种模式非常容易实现。
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