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

Question

I have a code that will copy and paste a whole row in worksheet called "Raw Data". If cells in Range $D$1:D have a value of "Thomas Xiong", then it will paste the whole row of everything under that value to another worksheet called "WIP".

What I am trying to do is be able to create a code that will be able to find multiple words. For example, "Thomas Xiong" and the word "Assigned" and be able to copy and paste that whole line from the worksheet "Raw Data" into another worksheet.

Also with the code I have now, it will copy and paste the whole rows but there are spaces in between each cell row in the other worksheet.

The code I have now:

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

The problem is you are using the row of the cells you are copying in your destination sheet. You want to use a separate counter that you increment every time you paste something on e given row:

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

What's not clear (to me at least) is if you want to only find rows where the value in column D is "Thomas Xiong" and the value in column C is "Assigned", in which case you want to have something like this:

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

To loop through a list of names (which I will assume to be in range A1:A10 in a worksheet called "myNames") something like this should work:

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