2

我有一个包含 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
4

2 回答 2

1

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

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

Non legend*这段代码所做的是将所有工作表中的列中的数据复制到Tab_AppendedA: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
于 2013-04-20T17:17:29.510 回答
0

消失的柱子

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

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

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

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

正如我所说，这段代码现在使您的列 A 消失...删除该行将使您的列 A 不会消失！

使用案例

要排除某些床单，使用案例很好，您使用它的方式也足以一次性完成。为了使其易于重复使用，我建议将要排除的工作表列表存储在工作表中，因为您可以将工作表名称拖放或添加到该列表中，而不必进入代码。

于 2013-04-20T15:18:15.270 回答