Объедините несколько файлов на один лист в качестве значений и удалите фильтры

Question

Я хотел бы объединить листы с одинаковым именем и форматом из нескольких файлов в один сводный лист.Я использовал этот код, но обнаружил, что он не будет копировать отфильтрованные данные или ячейки ссылок.Я также попробовал пару кодов, чтобы удалить фильтр, и скопированные данные становятся непрерывными.Может ли кто-нибудь разобраться в этом и помочь мне?Спасибо!

Sub Multiple_to_One()
Dim MyPath, MyName, AWbName
Dim Wb As Workbook, WbN As String
Dim G As Long
Dim Num As Long
Dim BOX As String
Dim lo As ListObject
Application.ScreenUpdating = False
MyPath = ActiveWorkbook.Path
MyName = Dir(MyPath & "\" & "*.xlsm")
AWbName = ActiveWorkbook.Name
Do While MyName <> ""
    If MyName <> AWbName Then
        Set Wb = Workbooks.Open(MyPath & "\" & MyName)
          With Workbooks(1).ActiveSheet
            Wb.Sheets(13).UsedRange.Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1)
            Wb.Close False
        End With
    End If
    MyName = Dir
Loop
MsgBox "All done.", vbInformation, "bingo"
End Sub

Answer 1

Это немного грубый метод, но, похоже, он работает:

Sub Summarize()
    Dim sourcePath As String
    Dim sourceName As String
    Dim sourceWorkbook as Workbook  ' Workbook to be copied
    Dim sourceSheet as Worksheet
    Dim thisWorkbookName as String
    Dim copyCell as Range
    Dim sourceBase as Range         ' Summary starts here

    Application.ScreenUpdating = False
    sourcePath = ActiveWorkbook.Path
    thisWorkbookName = ActiveWorkbook.Name
    sourceName = Dir(MyPath & "\" & "*.xlsm")
    Set sourceBase = Workbooks(1).ActiveSheet.Range("A1")  ' Set to what you want

    Do While sourceName <> ""
        If sourceName <> thisWorkbookName Then
            Set sourceWorkbook = Workbooks.Open(sourcePath & "\" & sourceName)
            Set sourceSheet = sourceWorkbook.Sheets(13)
            For Each copyCell In sourceSheet.UsedRange
                copyCell.Copy sourceBase.Offset(copyCell.Row - 1, copyCell.Column - 1)
            Next
            Set sourceBase = sourceBase.Offset(sourceSheet.UsedRange.Rows.Count)
            Set copyCell = Nothing
            Set sourceSheet = Nothing
            sourceWorkbook.Close False
        End If
        sourceName = Dir
    Loop

    Application.ScreenUpdating = True

    MsgBox "All done.", vbInformation, "bingo"

End Sub

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

Предостережение

Я только тестировал внутренний код в своем собственномпростынь.Я внес изменения на лету, чтобы вписать все в вашу оригинальную логику.Вся функция выше должна заменить вашу оригинальную функцию.Если у вас есть ошибки, это потому, что я что-то опечатал.Мои извинения.

Answer 2

Я установил режим автофильтра на False.В моем случае это сработало.
Wb.Sheets(13).AutoFilterMode = False

Вот модифицированный код.

Sub Multiple_to_One()
    Dim MyPath, MyName, AWbName
    Dim Wb As Workbook, WbN As String
    Dim G As Long
    Dim Num As Long
    Dim BOX As String
    Dim lo As ListObject
    Application.ScreenUpdating = False
    MyPath = ActiveWorkbook.Path
    MyName = Dir(MyPath & "\" & "*.xlsm")
    AWbName = ActiveWorkbook.Name

    Do While MyName <> ""
        If MyName <> AWbName Then
        Set Wb = Workbooks.Open(MyPath & "\" & MyName)
        Wb.Sheets(13).AutoFilterMode = False

        ThisWorkbook.Activate
          With Workbooks(1).ActiveSheet
            Wb.Sheets(13).UsedRange.Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1)
            Wb.Close False
        End With
    End If
    MyName = Dir
Loop

Application.ScreenUpdating = True

MsgBox "All done.", vbInformation, "bingo"

End Sub