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

我将autofiltermode设置为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"

结束子

Answer 2

这是一种蛮力的方法，但是似乎可行：

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

我只是手动将使用范围内的每个单元格复制到目标表中。每张纸之后，基本单元都会重置，因此它应该一直附加到目标纸上。

注意事项

我只在自己的工作表中测试了内部代码。我即时进行了调整，以使所有内容均符合您的原始逻辑。上面的整个功能应替换您的原始功能。如果您有任何错误，那是因为我输入了错误的内容。我很抱歉。

将多个文件合并为一张纸作为值并删除过滤器

2 个答案: