Копирование/Вставка нескольких строк в VBA

Question

Я пытаюсь сделать простую строку копирования, вставить строку в книгу. Я искал темы и несколько раз менял свой код, но безрезультатно.

Это тот, который ближе всего подходит для работы, но он копирует только один экземпляр критериев соответствия.

Я пытаюсь создать цикл, который скопирует все строки, имеющие совпадение в одном из столбцов.

Итак, если 8 столбцов, каждая строка с соответствующим значением в столбце 7 должна копироваться на именованный лист.

Sub test() 
 
Set MR = Sheets("Main").Range("H1:H1000") 
 
Dim WOLastRow As Long, Iter As Long 
 

 
    For Each cell In MR 
 
    
 
If cell.Value = "X" Then 
 
cell.EntireRow.Copy 
 
Sheets("X").Range("A" & Rows.Count).End(xlUp).PasteSpecial 
 
    End If 
 
If cell.Value = "Y" Then 
 
cell.EntireRow.Copy 
 
Sheets("Y").Range("A" & Rows.Count).End(xlUp).PasteSpecial 
 
    End If 
 
If cell.Value = "Z" Then 
 
cell.EntireRow.Copy 
 
Sheets("Z").Range("A" & Rows.Count).End(xlUp).PasteSpecial 
 
    End If 
 
If cell.Value = "AB" Then 
 
cell.EntireRow.Copy 
 
Sheets("AB").Range("A" & Rows.Count).End(xlUp).PasteSpecial 
 
    End If 
 
    
 
Application.CutCopyMode = False 
 

 
Next 
 

 
End Sub

Мне нравится это, потому что мне нужно ориентировать на несколько листов назначения с различными критериями, но мне нужны все строки, которые соответствуют критериям, чтобы скопировать.

Answer 1

EDITED код в ответ на новый запрос:

ниже код будет скопировать все строки в листе Main и вставить их в соответствующие рабочие листы на основе значения в колонке 7.

Обратите внимание: Если в столбце 7 есть значение, которое НЕ соответствует существующему имени листа, код выдает ошибку. Измените код, чтобы обработать это исключение.

Сообщите мне о любой дополнительной необходимости.

Sub CopyStuff() 
    Dim wsMain As Worksheet 
    Dim wsPaste As Worksheet 
    Dim rngCopy As Range 
    Dim nLastRow As Long 
    Dim nPasteRow As Long 
    Dim rngCell As Range 
    Dim ws As Worksheet 

    Const COLUMN_TO_LOOP As Integer = 7 

    Application.ScreenUpdating = False 

    Set wsMain = Worksheets("Main") 
    nLastRow = wsMain.Cells(Rows.Count, 1).End(xlUp).Row 
    Set rngCopy = wsMain.Range("A2:H" & nLastRow) 

    For Each ws In ActiveWorkbook.Worksheets 
     If UCase(ws.Name) = "MAIN" Then 
      'Do Nothing for now 
     Else 
      Intersect(ws.UsedRange, ws.Columns("A:H")).ClearContents 
     End If 
    Next ws 

    For Each rngCell In Intersect(rngCopy, Columns(COLUMN_TO_LOOP)) 
     On Error Resume Next 
     Set wsPaste = Worksheets(rngCell.Value) 
     On Error GoTo 0 

     If wsPaste Is Nothing Then 
      MsgBox ("Sheet name: " & rngCell.Value & " does not exist") 
     Else 

      nPasteRow = wsPaste.Cells(Rows.Count, 1).End(xlUp).Row + 1 

      wsMain.Range("A" & rngCell.Row).Resize(, 8).Copy wsPaste.Cells(nPasteRow, 1) 
     End If 

     Set wsPaste = Nothing 
    Next rngCell 

    Application.ScreenUpdating = True 
End Sub 

Answer 2

Ваш текущий код вставки в той же строке в каждом листе снова и снова, до последней строки со значением в столбце А. Range("A" & Rows.Count).End(xlUp) говорит, грубо «перейти к самой нижней части таблицы в колонке А , а затем перепрыгнуть оттуда в следующую нижнюю ячейку в столбце A с содержимым ", которая возвращает вас в одну и ту же ячейку каждый раз.

Вместо этого вы можете использовать линии рисунка:

Sheets("X").Range("A" & Sheets("X").UsedRange.Rows.Count + 1).PasteSpecial 

Где UsedRange это диапазон, содержащий все ячейки на листе с данными в них. + 1 помещает вас в следующую строку.

Вы могли бы сделать это немного симпатичнее с помощью With:

With Sheets("X")  
    .Range("A" & .UsedRange.Rows.Count + 1).PasteSpecial  
End With