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

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

顺便说一句，我排除了几个工作表“案件”是否有一个更优雅的方式来排除所有包含string“传奇”，而不是我的所有工作表的列表？

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

使用案例

要排除某些表格，使用的情况是好的，也是你用它的方式是足够好的一个closures。 为了使其易于重复使用，我build议将要排除的工作表的列表存储在工作表中，然后删除或添加工作表名称到列表中，而不必进入代码。