Новые строки не добавляются в существующие строки в новой книге.

Question

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

Исходная рабочая книга состоит из 10 листов, каждый из которых содержит разные детали, но каждый лист изложен одинаково, то есть заголовки столбцов одинаковы. У каждого листа есть своя собственная кнопка, которая копирует строки «Да» в одну и ту же книгу назначения, причем все они оказываются на одном листе. Столбец L - это столбец Да / Нет. Я могу скопировать только строки «Да» в целевую книгу, но они вставляются в верхний ряд, который переопределяет уже существующие строки. На исходном листе мне нужно скопировать из строки 14 и вставить в лист назначения в строке 6. Любая помощь с моим кодом будет принята с благодарностью.

Private Sub CommandButton2_Click()
    Dim i As Long
    Dim outRow As Long
    Dim sourceWs As Worksheet, destWs As Worksheet

    Set sourceWs = Workbooks("SrcTest.xlsm").Worksheets("SRU 1")
    Set destWs = Workbooks.Open("DestTest.xlsx").Worksheets("All Data")

    outRow = 6

    For i = 14 To 200
        If sourceWs.Cells(i, 12).Value = "Yes" Then
            sourceWs.Rows(i).EntireRow.Copy
            destWs.Rows(outRow).PasteSpecial (xlPasteValues)
            outRow = outRow + 1                 ' not adding new rows under existing rows
            Application.CutCopyMode = False
        End If
    Next i 
End Sub

Ожидаемый результат - каждый раз, когда я нажимаю кнопку, все строки со знаком Да в столбце L копируются в целевую книгу под любыми существующими строками. Это должно происходить независимо от того, какой исходный лист я использую (от 1 до 10).

Answer 1

Вместо зацикливания для каждой строки (что отнимает много времени), вы можете просто отфильтровать ваши данные, используя критерии "Yes", и скопировать вставить только один раз так:

Option Explicit
Private Sub CommandButton2_Click()
    Dim i As Long
    Dim outRow As Long
    Dim Col As Integer
    Dim sourceWs As Worksheet, destWs As Worksheet

    Set sourceWs = Workbooks("SrcTest.xlsm").Worksheets("SRU 1")
    Set destWs = Workbooks.Open("DestTest.xlsx").Worksheets("All Data")

    outRow = destWs.Cells(destWs.Rows.Count, 1).End(xlUp).Row + 1 'next available row on destination workbook

    With sourceWs
        i = .Cells(.Rows.Count, 1).End(xlUp).Row 'last used row on the sheet
        .Rows(13).AutoFilter Field:=12, Criteria1:="Yes" 'no need to loop, just filter the sheet with your criteria
        .Range("A2", .Cells(i, "M")).SpecialCells(xlCellTypeVisible).Copy 'copy the visible rows
        .AutoFilterMode = False
    End With
    destWs.Cells(outRow, 1).PasteSpecial xlPasteValues
    destWs.Cells(outRow, 1).PasteSpecial xlPasteFormats

End Sub

Мой код предполагает, что у вас естьданные по столбцу A на обоих листах.