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”而中的列{{1 }}是“已分配”，在这种情况下，您希望具有以下内容：

要遍历名称列表（在工作表“ myNames”中，我会假设它们位于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范围内），类似这样的事情应该起作用：

A1:A10

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

1 个答案: