Мне нужно скопировать несколько листов в рабочей книге в сводный лист на основе критериев, согласно которым значение в 22-м поле в определенном тексте

Question

У меня есть код, который не работает при копировании данных с нескольких листов в один на основе критериев автофильтра.

Я пробовал этот код, и он копирует данные с разных листов, но при применении условия автофильтра он перестает работать

Sub CopyDataWithoutHeaders()
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim shLast As Long
    Dim CopyRng As Range
    Dim StartRow As Long
    Dim WSNew As Worksheet
    Dim MyRange As Range
    Dim my_range As Range
    Dim Rng As Range


    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

     'Add a worksheet
     'Set DestSh = ActiveWorkbook.Worksheets.Add

    Set DestSh = ActiveWorkbook.Worksheets("Sheet16")
    'DestSh.Name = "Destination"

    'Fill in the start row
    StartRow = 2

    'loop through all worksheets and copy the data to the DestSh
    For Each sh In ActiveWorkbook.Worksheets
        If IsError(Application.Match(sh.Name, _
    Array(DestSh.Name, "Format", "Lookups"), 0)) And sh.Visible = True Then
            'Find the last row with data on the DestSh and sh
            Last = LastRow(DestSh)
            shLast = LastRow(sh)
            MsgBox sh.Name

    Set my_range = Range("A1:ZZ" & LastRow(ActiveSheet))
        my_range.Parent.Select


            'If sh is not empty and if the last row >= StartRow copy the CopyRng
            If shLast >= StartRow Then


            my_range.Parent.AutoFilterMode = False
           ActiveSheet.Range("A1").AutoFilter Field:=22, Criteria1:="=Ready to import"
            'ActiveSheet.AutoFilter.Range.Offset(1, 0).Rows.SpecialCells(xlCellTypeVisible).Copy

             With my_range.Parent.AutoFilter.Range

    Set Rng = .Offset(1, 0).Resize(.Rows.Count, .Columns.Count) _
                  .SpecialCells(xlCellTypeVisible)

                  MsgBox my_range



If Not Rng Is Nothing Then
            'Copy and paste the cells into DestSh below the existing data
            Rng.Copy
            With DestSh.Range("A" & LastRow(DestSh) + 1)
                .PasteSpecial Paste:=8
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
            End With
          End If

'            Intersect(.UsedRange, .UsedRange.Offset(1)).SpecialCells(xlCellTypeVisible).Copy
'            DestSh.Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues




        MsgBox Last

'        With DestSh.Cells(Last + 1, "A")
'        .PasteSpecial Paste:=8
'            .PasteSpecial xlPasteValues
'            .PasteSpecial xlPasteFormats
'             Application.CutCopyMode = False
'            .Select
'        End With
 ' End If

    'Close AutoFilter
    my_range.Parent.AutoFilterMode = False

                'Set the range that you want to copy

               ' Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))

                'Test if there enough rows in the DestSh to copy all the data
'                If Last + MyRange.Rows.Count > DestSh.Rows.Count Then
'                   MsgBox "There are not enough rows in the Destsh"
'                    GoTo ExitTheSub
'                End If

                'This example copies values/formats, if you only want to copy the
                'values or want to copy everything look below example 1 on this page
'                CopyRng.Copy
'                With DestSh.Cells(Last + 1, "A")
'                    .PasteSpecial xlPasteValues
'                    .PasteSpecial xlPasteFormats
'                    Application.CutCopyMode = False
End With

            End If

        'End If





'ExitTheSub:
'
'    Application.Goto DestSh.Cells(1)
'
'    'AutoFit the column width in the DestSh sheet
'    DestSh.Columns.AutoFit
'
'    With Application
'        .ScreenUpdating = True
'        .EnableEvents = True
   'End With
End Sub





Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function


Function LastCol(sh As Worksheet)
    On Error Resume Next
    LastCol = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
    On Error GoTo 0
End Function

Все листы должны быть скопированы один под другим, если все они соответствуют критериям

Answer 1

Спасибо за помощь

Решена проблема

Sub CopyDataWithoutHeaders ()

Dim ws As Worksheet, DestSh As Worksheet, Rng As Range

Set DestSh = ThisWorkbook.Sheets("All")

With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

For Each ws In ThisWorkbook.Sheets

     If ws.Name <> "Format" And ws.Name <> "Lookups" And ws.Name <> DestSh.Name Then

        Set Rng = ws.UsedRange

        With Rng 'will copy all the range except the header row

           .AutoFilter Field:=22, Criteria1:="Ready to import", Operator:=xlAnd

           ***If (ws.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count > 1)*** Then

            .Offset(1, 0).Resize(Rng.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy
            DestSh.Cells(Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteValues

           End If

        End With

    End If

    'clean up each worksheet
    ws.AutoFilterMode = False
    Application.CutCopyMode = False
Next ws

With Application
    .ScreenUpdating = True
    .EnableEvents = True
End With

End Sub

Функция LastRow (sh As Worksheet)При ошибке возобновить следующую LastRow = sh.Cells.Find (What: = "*", _ After: = sh.Range ("A1"), _ Lookat: = xlPart, _ LookIn: = xlFormulas, _ SearchOrder: = xlByRows,_ SearchDirection: = xlPrevious, _ MatchCase: = False). Строка при ошибке Перейти к 0 Завершить функцию

Answer 2

Это основной код, который вы пытаетесь выполнить.

Sub CopyDataWithoutHeaders()
    Dim ws As Worksheet, DestSh As Worksheet, Rng As Range
    Set DestSh = ThisWorkbook.Sheets("Sheet16")

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    For Each ws In ThisWorkbook.Sheets
        If ws.Name <> "Format" And ws.Name <> "Lookups" And ws.Name <> DestSh.Name Then

            'the below line will not select the complete range if a cell is empty in column 1
            'it can be changed to the way you want.
            Set Rng = ws.Range("A1", ws.Range("A1").End(xlDown).End(xlToRight))

            With Rng 'will copy all the range except the header row  
                .AutoFilter Field:=22, Criteria1:="Ready to import", Operator:=xlAnd
                .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy
            End With

                'test if the first cell is empty before pasting 
                If DestSh.Range("A1") = "" Then
                    DestSh.Cells(Rows.Count, "A").End(xlUp).PasteSpecial xlPasteValues

                Else: DestSh.Cells(Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteValues
                End If
        End If

        'clean up each worksheet
        ws.AutoFilterMode = False
        Application.CutCopyMode = False
    Next ws

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub