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 A：M。希望这是你想要的？如果没有，请告诉我，我会纠正这个帖子。

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

Answer 2

消失栏

您的代码段中有一些奇怪的代码：

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

因此，在复制完所有工作表内容后，此行将删除A列，这不是您想要的。

此外，代码错误，因为删除列然后向上移位（xlUp）是不可能的。您可以删除一行并将其向上移动，或删除一列并向左移动。

正如我所说，此代码现在使您的A栏消失...删除该行会使您的A栏不再消失！

使用案例

要排除某些纸张，使用的情况很好，您使用它的方式也足够一次性。为了使其易于重复使用，我建议存储要在工作表中排除的工作表列表，然后您可以将工作表名称删除或添加到该列表中，而不必进入代码。

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

2 个答案: