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

Question

我有一个带有116个工作表的Excel文件，我想将它们追加到一个工作表中（“Tab_Appended”）。我试过下面的代码，它的工作原理。但是，工作表中的列A未粘贴到Tab_Appended - 我必须更改代码以实现将除标题行以外的所有数据都复制到Tab_Appended？

BTW，我排除了几张与“案例”是有排除包含字符串“传奇”，而不是我的所有工作表的上市的所有图纸更优雅的方式？

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列的消失！

使用情况

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