Скопируйте и вставьте код VBA - я хочу использовать на нескольких листах

Question

Я очень новичок в VBA. У меня есть код, который будет копировать данные, которые соответствуют определенным критериям на одном листе, на другой мастер-лист. У меня есть несколько других листов, которые я хочу скопировать в мастер. Как мне изменить мой код, чтобы сделать это, пожалуйста?

Заранее спасибо.

Sub copyPaste()
    Dim ws As Worksheet
    Dim wt As Worksheet
    Set ws = Sheets("S_Q")
    Set wt = Sheets("master")
    Dim i As Integer
    Dim lr As Integer
    lr = ws.Range("y" & Rows.Count).End(xlUp).Row
    Dim lt As Long

    For i = 1 To lr
    lt = wt.Range("y" & Rows.Count).End(xlUp).Row
        If ws.Range("bz" & i) > 14 Then
        ws.Range("y" & i).EntireRow.Copy wt.Range("a" & lt + 1)
        End If
    Next i
End Sub

Answer 1

Я бы поместил интересующие вас листы в массив и зациклил его. Я бы также использовал Union, чтобы собрать квалификационные диапазоны и вставить за один раз, чтобы быть более эффективным.

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

Кроме того, используйте Long вместо Integer, чтобы избежать потенциального переполнения, поскольку на листе больше строк, чем может обработать Integer.

Option Explicit

Public Sub copyPaste()
    Dim ws As Worksheet, wt As Worksheet, sheetsOfInterest(), unionRng As Range
    Dim i As Long, lastRow As Long, lastRowMaster As Long
    Application.ScreenUpdating = False
    sheetsOfInterest = Array("Sheet1", "Sheet2", "S_Q")

    Set wt = ThisWorkbook.Worksheets("master")

    For Each ws In ThisWorkbook.Worksheets(sheetsOfInterest)

        lastRow = GetLastRow(ws, 25)

        For i = 1 To lastRow

            If ws.Range("BZ" & i) > 14 Then
                If Not unionRng Is Nothing Then
                    Set unionRng = Union(unionRng, ws.Range("bz" & i))
                Else
                    Set unionRng = ws.Range("BZ" & i)
                End If
            End If
        Next i
        If Not unionRng Is Nothing Then
            With wt
                unionRng.EntireRow.Copy .Range("A" & GetLastRow(wt, 1) + 1)
            End With
        End If
        Set unionRng = Nothing
    Next
    Application.ScreenUpdating = True
End Sub

Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
    With ws
        GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row
    End With
End Function

Answer 2

После пробного фильтра на разных столбцах и работает он на одних, а не на других; без видимых рассуждений. Я решил перенастроить таблицы и поместить столбец для фильтрации в первый столбец. Это, кажется, работает до сих пор.

Answer 3

Не вдаваясь слишком подробно в особенности самого вашего кода - будут ли критерии одинаковыми для всех рабочих листов, на которых вы хотите его запустить? И есть ли расположение данных во всех этих таблицах?

Если это так, и если ваш текущий код делает то, что вам нужно, чтобы он работал с рабочим листом A, и нам просто нужно расширить его, чтобы он также обрабатывал рабочие листы с B по X, тогда вы могли бы избавиться от ваших dim / set ws строк, и вместо этого измените свою первую строку на

sub copyPaste(ws as worksheet)

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

call copyPaste(ThisWorkbook.Sheets("S_Q"))