Как скопировать и добавить отфильтрованные данные из нескольких листов в один лист назначения с помощью цикла?

Question

РЕДАКТИРОВАТЬ: я вставил некоторые пересмотренный код ниже в разделе Sub (Copyinternal).Все еще не работает, но, возможно, я на правильном пути?

У меня есть рабочая книга с 6 вкладками.Листы настраиваются следующим образом:

1. Органы управления
2. Прогноз
3. Финансовое обновление
4. Цели Совета
5. Внутренний календарь
6. Внешний календарь

Листы 2-4 содержат таблицы данных, которые я хотел бы отфильтровать двумя различными способами и скопировать / вставить в обе вкладки 5 и 6 без перезаписи.Листы 5 и 6 содержат заголовки в строке 1, которые я хотел бы сохранить.

Попытка:

1. Сначала удалите любую существующую информацию на листе «Внутренний календарь» и «Внешний календарь»лист со строки 2 вниз без удаления заголовков.
2. На листе «Прогноз» отфильтруйте столбец H для выбора «Оба» и «Внутренний», а затем скопируйте / вставьте эту информацию в лист «Внутренний календарь», начиная сстолбец C. Затем я пытаюсь сделать то же самое для листов «Финансовое обновление» и «Цели Совета», но скопируйте / вставьте отфильтрованную информацию после содержимого, уже вставленного во «Внутренний календарь», чтобы не перезаписывать информацию.
3. Повторите шаг 2, за исключением фильтра H для «Оба» и «Внешний», а также «Скопируйте / вставьте отфильтрованную информацию в« Внешний календарь », начиная со столбца С.
4. Элемент управления можно игнорировать.

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

Я довольно новичок в использовании VBA, поэтому руководство в правильном направлении поможеточень ценим.

Sub CalendarAutomation()

    ClearSheets
    CopyInternal
    CopyExternal


End Sub

Sub ClearSheets()

    'Clear out Contents
    Sheets("Internal Calendar").Select
    activesheet.Range("C2:G250").Select
    Selection.ClearContents
    Sheets("External Calendar").Select
    Range("C2:G250").Select
    Selection.ClearContents

End Sub

Sub CopyInternal()

Dim ws As Variant
Dim starting_ws As Worksheet
Dim ending_ws As Worksheet
Dim rng As range
Set starting_ws = ThisWorkbook.Worksheets("Forecast")
Set ending_ws = ThisWorkbook.Worksheets("Internal Calendar")
Set rng = ActiveRange


For ws = 2 To 4

    If Selection.AutoFilter = OFF Then Selection.AutoFilter

    ws.rng.AutoFilter Field:=6, Criteria1:="=Both", _
        Operator:=xlOr, Criteria2:="=Internal"
    UsedRange.Copy
    ending_ws.range(Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).Row).Paste
Next ws

End Sub

Sub CopyExternal()

Dim ws As Worksheet
Dim unusedRow As Long

    For Each ws In ThisWorkbook.Worksheets
    If Not ws.Name = "Controls" _
    And Not ws.Name = "Internal Calendar" _
    And Not ws.Name = "External Calendar" Then

    Range("$C$3:$H$14").AutoFilter Field:=6, Criteria1:="=Both", _
        Operator:=xlOr, Criteria2:="=External"
    Range("C4:G14").Select
    Selection.Copy
    Sheets("External Calendar").Select
    activesheet.Paste
    unusedRow = Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).Row
    End If

Next ws

End Sub

Answer 1

Ваш код после изменений (надеюсь, он будет работать для вас, но есть место для улучшения):

    Sub CalendarAutomation()

        ClearSheets
        CopyInternal
        CopyExternal

    End Sub

    Sub ClearSheets()

        'Clear out Contents
        Sheets("Internal Calendar").Range("C2:G250").ClearContents
        Sheets("External Calendar").Range("C2:G250").ClearContents

    End Sub

    Sub CopyInternal()

        Dim ws As Variant
        Dim starting_ws As Worksheet
        Dim ending_ws As Worksheet
        Dim rng As Range
        Set starting_ws = ThisWorkbook.Worksheets("Forecast")
        Set ending_ws = ThisWorkbook.Worksheets("Internal Calendar")

        For ws = 2 To 4

            If Sheets(ws).AutoFilterMode Then Sheets(ws).Range("A1").AutoFilter

            Sheets(ws).Range("A1").AutoFilter 6, "Both", xlOr, "Internal"
            Sheets(ws).UsedRange.Copy
            ending_ws.Cells(ending_ws.Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).Row, 3).PasteSpecial xlPasteAll 'pasting into "C" column
        Next ws

    End Sub

    Sub CopyExternal()

        Dim ws As Worksheet
        Dim unusedRow As Long
        Dim external As Worksheet: Set external = ThisWorkbook.Worksheets("External Calendar")
        For Each ws In ThisWorkbook.Worksheets
            If Not ws.Name = "Controls" _
            And Not ws.Name = "Internal Calendar" _
            And Not ws.Name = "External Calendar" Then

                unusedRow = external.Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).Row    'if you want to find last filled row i suggest to change to: external.cells(external.rows.count, [column number]).end(xlup).row
                ws.Range("A1").AutoFilter Field:=6, Criteria1:="=Both", _
                    Operator:=xlOr, Criteria2:="=External"
                ws.UsedRange.Copy
                external.Cells(unusedRow, 1).PasteSpecial xlPasteAll 'paste into "A" column

            End If

        Next ws

    End Sub

Answer 2

Попробуйте это:

    Sub tst()

        Dim ctrl As Worksheet: Set ctrl = ThisWorkbook.Sheets("Controls")
        Dim fcast As Worksheet: Set fcast = ThisWorkbook.Sheets("Forecast")
        Dim fu As Worksheet: Set fu = ThisWorkbook.Sheets("Financial Update")
        Dim bg As Worksheet: Set bg = ThisWorkbook.Sheets("Board Goals")
        Dim ic As Worksheet: Set ic = ThisWorkbook.Sheets("Internal Calendar")
        Dim ec As Worksheet: Set ec = ThisWorkbook.Sheets("External Calendar")

        Dim ic_last_r As Long
        Dim ec_last_r As Long

        ic_last_r = ic.Cells(ic.Rows.Count, 3).End(xlUp).Row
        ec_last_r = ec.Cells(ec.Rows.Count, 3).End(xlUp).Row

        If ic_last_r < 2 Then ic_last_r = 2     'avoid deleting 1st row
        If ec_last_r < 2 Then ec_last_r = 2

        ic.Rows("2:" & ic_last_r).ClearContents
        ec.Rows("2:" & ec_last_r).ClearContents

        copy_paste fcast, ic, "Both", "Internal", Array("Controls", "Forecast", "External Calendar")
        copy_paste fcast, ec, "Both", "External", Array("Controls", "Forecast", "Internal Calendar")

    End Sub


    Sub copy_paste(ws1 As Worksheet, ws2 As Worksheet, c1 As String, c2 As String, wsheets)
        Dim ws As Worksheet
        Dim ws2_last_r As Long

        For Each ws In ThisWorkbook.Worksheets
            For i = LBound(wsheets) To UBound(wsheets)
                If ws.Name = wsheets(i) Then GoTo n_ext
            Next

            ws2_last_r = ws2.Cells(ws2.Rows.Count, 3).End(xlUp).Row

            ws1.Range("A1").AutoFilter 8, c1, xlOr, c2
            ws1.Range("A1").CurrentRegion.Columns("C:G").Copy

            ws2.Range("C" & ws2_last_r).PasteSpecial xlPasteAll

            ws1.Range("A1").AutoFilter
 n_ext:
        Next
    End Sub