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

使用情況

排除某些紙張的使用情況是好的，也是你用它的方式是不夠好一次性的。爲了使它適用於重複使用，我建議將要排除的工作表的列表存儲在工作表中，然後將工作表名稱添加到該列表中，而不必進入代碼。