Код 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 равно "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

To loopчерез список имен (который я буду считать в диапазоне A1:A10 на листе с именем «myNames») что-то вроде этого должно работать:

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