VBA代碼可將特定單元格中的特定單詞復制並粘貼到另一個工作表中

Question

我有一個代碼，它將在工作表中復制並粘貼整行，稱為“原始數據”。 如果范圍$ D $ 1：D中的單元格的值為“ Thomas Xiong”，則它將把該值下的所有內容的整個行粘貼到另一個名為“ WIP”的工作表中。

我正在嘗試做的是能夠創建一個能夠找到多個單詞的代碼。 例如，“ Thomas Xiong”和單詞“ Assigned”，並能夠將整個行從工作表“原始數據”復制並粘貼到另一個工作表中。

同樣，使用我現在擁有的代碼，它將復制並粘貼整個行，但是另一個工作表中的每個單元格行之間都有空格。

我現在擁有的代碼：

Sub Test()

Dim Cell As Range

With Sheets("Raw Data")
' loop column C untill last cell with value (not entire column)
For Each Cell In .Range("D1:D" & .Cells(.Rows.Count, "D").End(xlUp).Row)
    If Cell.Value = "Thomas Xiong" Then
         ' Copy>>Paste in 1-line (no need to use Select)
        .Rows(Cell.Row).copy Destination:=Sheets("WIP").Rows(Cell.Row)
        '.Range("C1:C", "A", "B", "D", "F" & Cell.Row).copy
    End If
  Next Cell
For Each Cell In .Range("C1:C" & .Cells(.Rows.Count, "C").End(xlUp).Row)
    If Cell.Value = "Assigned" Then
         ' Copy>>Paste in 1-line (no need to use Select)
        .Rows(Cell.Row).copy Destination:=Sheets("WIP").Rows(Cell.Row)
        '.Range("C1:C", "A", "B", "D", "F" & Cell.Row).copy
    End If
Next Cell
End With

End Sub

Answer 1

問題是您正在使用目標表中要復制的單元格行。 您想使用一個單獨的計數器，該計數器每次在給定行上粘貼某些內容時都會遞增：

Sub Test()

Dim Cell As Range
Dim myRow as long

myRow = 2
With Sheets("Raw Data")
    ' loop column C untill last cell with value (not entire column)
    For Each Cell In .Range("D1:D" & .Cells(.Rows.Count, "D").End(xlUp).Row)
        If Cell.Value = "Thomas Xiong" Then
             ' Copy>>Paste in 1-line (no need to use Select)
            .Rows(Cell.Row).copy Destination:=Sheets("WIP").Rows(myRow)
            myRow = myRow + 1
        End If
    Next Cell
    For Each Cell In .Range("C1:C" & .Cells(.Rows.Count, "C").End(xlUp).Row)
        If Cell.Value = "Assigned" Then
            ' Copy>>Paste in 1-line (no need to use Select)
            .Rows(Cell.Row).copy Destination:=Sheets("WIP").Rows(myRow)
            myRow = myRow + 1
        End If
    Next Cell
End With

End Sub

尚不清楚（至少對我而言）是，如果您只想查找D列中的值為“ Thomas Xiong” 而 C列中的值為“ Assigned”的行，在這種情況下，您希望具有以下內容：

Sub Test()

Dim Cell As Range
Dim myRow as long

myRow = 2
With Sheets("Raw Data")
    For Each Cell In .Range("C1:C" & .Cells(.Rows.Count, "C").End(xlUp).Row)
        If Cell.Value = "Assigned" and Cell.Offset(0,1).Value = "Thomas Xiong" Then
            ' Copy>>Paste in 1-line (no need to use Select)
            .Rows(Cell.Row).copy Destination:=Sheets("WIP").Rows(myRow)
            myRow = myRow + 1
        End If
    Next Cell
End With

End Sub

要遍歷名稱列表（在工作表“ myNames”中，我假定其位於范圍A1:A10中），應執行以下操作：

Sub Test()

Dim Cell as Range
Dim NameCell as Range
Dim myRow as Long

myRow = 2
With Sheets("Raw Data")
    For each NameCell in Worksheet("myNames").Range("A1:A10)
        For Each Cell In .Range("C1:C" & .Cells(.Rows.Count, "C").End(xlUp).Row)
            If Cell.Value = "Assigned" and Cell.Offset(0,1).Value = NameCell.Value Then
                .Rows(Cell.Row).copy Destination:=Sheets("WIP").Rows(myRow)
                myRow = myRow + 1
                Exit For
            End If
        Next Cell
    Next NameCell
End With

End Sub