VBA代码将不同单元格中的特定单词复制并粘贴到另一个工作表

Question

我有一个代码可以复制并粘贴一整行到名为“原始数据”的工作表中。如果范围 $D$1:D 中的单元格的值为“Thomas Xiong”，那么它将将该值下的所有内容的整行粘贴到另一个名为“WIP”的工作表中。

我想要做的是能够创建一个能够找到多个单词的代码。例如，“Thomas Xiong”和“Assigned”一词，并且能够将整行从工作表“Raw Data”复制并粘贴到另一个工作表中。

还有我现在拥有的代码，它会复制并粘贴整行，但另一个工作表中的每个单元格行之间都有空格。

我现在的代码：

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 列中的值为“已分配”，在这种情况下，您想要这样的东西：

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