vlookup，如果條件複製數據vba

Question

我有一個代碼複製數據從一張表到另一張如下，但其查找部分不起作用。如果我不使用查找功能，然後代碼工作良好

Sub CopyRows() 

Dim Rng As Range 
Dim Rng2 As Range 
Dim Cl As Range 
Dim str As String 
Dim RowUpdCrnt As Long 

Set UsedRange = Sheets("Jan").Range("b5:bk81") 
Set Rng = Sheets("Jan").UsedRange 'the range to search ie the used range 
Set Rng2 = Sheets("Feb").Range("I5:AK5") 

str = "WRK." 'string to look for 
Sheets("Feb").Range("B5:B81").Value = "" 
RowUpdCrnt = 5 

' In my test data, the "WRK."s are in column AN. This For-Each only selects column AN. 
' I assume all my "WRK."s are in a single column. Replace "B" by the appropriate 
' column letter for your data. 

For Each Cl In Rng.Columns("AN").Rows 
    If Cl.Text = str Then 
     'if the cell contains the correct value copy it to next empty row on sheet 2 & delete the row 
     VLookup(Cl.EntireRow.Range("b1"), Sheets("Master").Range("H7:H200"), 1, 0).Copy 
     Sheets("Feb").Cells(RowUpdCrnt, 2).PasteSpecial xlPasteValues 
     RowUpdCrnt = RowUpdCrnt + 1 
    End If 
Next Cl 
Application.CutCopyMode = False 

End Sub 

Answer 1

根據您的文章，您要複製的唯一事情是價值觀，所以你可以有資格細胞（不使用複製粘貼>> ），通過使用Sheets("Feb").Range("B" & RowUpdCrnt).Value = Application.VLookup(.Range("B" & Cl.Row).Value, Sheets("Master").Range("H7:H200"), 1, 0)

嘗試下面的代碼：

With Sheets("Jan") 
    ' loop until last row with data in Column AN (and not the entire column) to save time 
    For Each Cl In .Range("AN1:AN" & .Cells(.Rows.Count, "AN").End(xlUp).Row) 
     If Cl.Value Like str Then 
      'if the cell contains the correct value copy it to next empty row on sheet 2 & delete the row 
      If Not IsError(Application.VLookup(.Range("B" & Cl.Row).Value, Sheets("Master").Range("H7:H200"), 1, 0)) Then ' <-- verify the VLookup was successful 
       Sheets("Feb").Range("B" & RowUpdCrnt).Value = Application.VLookup(.Range("B" & Cl.Row).Value, Sheets("Master").Range("H7:H200"), 1, 0) 
       RowUpdCrnt = RowUpdCrnt + 1 
      End If 
     End If 
    Next Cl 
End With