excel - 将多个 Excel 工作表附加到一个工作表中

Question

我有一个包含 116 张工作表的 excel 文件，我想将其附加到一张工作表中(“Tab_Appended”)。我尝试了以下代码并且它有效。但是，工作表中的 A 列未粘贴到 Tab_Appended - 我必须在哪里更改代码才能实现除标题行之外的所有数据都复制到 Tab_Appended？

顺便说一句，我排除了几张带有“case”的表格是否有更优雅的方法来排除包含字符串“legend”的所有表格，而不是我列出所有表格？

Sub SummurizeSheets()
    Dim ws As Worksheet
    Dim lastRng As Range
    Dim lastCll As Range

    Application.ScreenUpdating = False
    Sheets("Tab_Appended").Activate

    For Each ws In Worksheets
        Set lastRng = Range("A65536").End(xlUp).Offset(1, 0)
        Select Case ws.Name
        Case "Tab_Appended", "Legende 1", "Legende 2", "Legende 3", "Legende 4", "Legende 5", "Legende 6", "Legende 7", "Legende 8", "Legende 9", "Legende 10", "Legende 11", "Legende 12", "Legende 13"
        'do nothing
        Case Else
            Set lastCll = ws.Columns(1).Find(What:="*", After:=ws.Range("A1"), SearchDirection:=xlPrevious)
            ws.Range("A2:" & lastCll.Address).Copy
            Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)
             'add sheet name before data
            lastRng.Resize(lastCll.Row - 1) = ws.Name
        End Select
    Next ws

    Columns("A").SpecialCells(xlBlanks).EntireRow.Delete (xlUp)

    Application.ScreenUpdating = True

End Sub

Answer 1

我已经对代码进行了注释，以便您理解它不会有任何问题。

关于您关于忽略具有 Legend 的工作表的问题;是的，有一种优雅的方式，那就是使用 INSTR .见下文。

这段代码所做的是从所有 Non legend* 的列中复制数据。床单到 Tab_Appended是。希望这是你想要的？如果没有，请告诉我，我会更正帖子。

Sub SummurizeSheets()
    Dim wsOutput As Worksheet
    Dim ws As Worksheet
    Dim wsOLr As Long, wsLr As Long

    Application.ScreenUpdating = False

    '~~> Set this to the sheet where the output will be dumped
    Set wsOutput = Sheets("Tab_Appended")

    With wsOutput
        '~~> Get Last Row in "Tab_Appended" in Col A/M and Add 1 to it
        wsOLr = .Range("A:M").Find(What:="*", After:=.Range("A1"), _
                Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious, MatchCase:=False).Row + 1

        '~~> Loop through sheet
        For Each ws In Worksheets
            '~~> Check if the sheet name has Legende
            Select Case InStr(1, ws.Name, "Legende", vbTextCompare)

            '~~> If not then
            Case 0
                With ws
                    '~~> Get Last Row in the sheet
                    wsLr = .Range("A:M").Find(What:="*", After:=.Range("A1"), _
                           Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, _
                           SearchDirection:=xlPrevious, MatchCase:=False).Row

                    '~~> Copy the relevant range
                    .Range("A2:M" & wsLr).Copy wsOutput.Range("A" & wsOLr)

                    '~~> Get Last Row AGAIN in "Tab_Appended" in Col A/B and Add 1 to it
                    wsOLr = wsOutput.Range("A:M").Find(What:="*", After:=wsOutput.Range("A1"), _
                            Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, MatchCase:=False).Row + 1
                End With
            End Select
        Next
    End With

    Application.ScreenUpdating = True
End Sub