Excel 合并器代码-如何合并多个工作簿

我有一个VBA代码，如下所示：

Sub GetSheets()
    Path = "C:\Users\DDC\Desktop\data\"
    Filename = Dir(Path & "*.xls")
    Do While Filename <> ""
        Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
        For Each Sheet In ActiveWorkbook.Sheets
            Sheet.Copy After:=ThisWorkbook.Sheets(1)
        Next Sheet
        Workbooks(Filename).Close
        Filename = Dir()
    Loop
End Sub

Sub-GetSheets（）
Path=“C:\Users\DDC\Desktop\data\”
Filename=Dir（路径&“*.xls”）
文件名“”时执行此操作
工作簿。打开文件名：=路径和文件名，只读：=真
对于ActiveWorkbook.Sheets中的每个工作表
Sheet.Copy After:=此工作簿.Sheets（1）
下一页
工作簿（文件名）。关闭
Filename=Dir（）
环
端接头

此VBA代码将多个excel合并为具有不同工作表的单个excel。 如果我们有100个excel，在一个空单元格上运行此代码将用100张工作表合并新的空excel。 例如，假设我有两个不同的EXCEL，格式相似（包含相同的标题），每个EXCEL包含10行数据

我的要求是，在运行此代码后，我希望o/p excel只有一张包含20行数据的工作表合并到一张工作表中。我不要两张分开的纸

---

目前，我正在尝试对95张工作表执行相同的操作，如果我必须手动将每张工作表复制到主工作表中，那么代码就没有意义了

可能是这样的：

Sub GetSheets()
lr1 = Columns(1).Rows.Count
Set target = ThisWorkbook.ActiveSheet
Path = "C:\Users\DDC\Desktop\data\"
Filename = Dir(Path & "*.xls")
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
With Sheets(Sheet.Name) 'change "A" according to your need - change 15 according to your need
lr = .Columns(1).Rows.Count
.Range("A2", .Range("A" & lr).End(xlUp).Offset(0, 15)).Copy Destination:=target.Range("A" & lr1).End(xlUp).Offset(1, 0)
End With
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop
End Sub

Sub-GetSheets（）
lr1=列（1）.行数.Count
设置目标=ThisWorkbook.ActiveSheet
Path=“C:\Users\DDC\Desktop\data\”
Filename=Dir（路径&“*.xls”）
文件名“”时执行此操作
工作簿。打开文件名：=路径和文件名，只读：=真
对于ActiveWorkbook.Sheets中的每个工作表
使用Sheet（Sheet.Name）'根据需要更改“A”-根据需要更改15
lr=.Columns（1）.Rows.Count
.Range（“A2”、.Range（“A”&lr）.End（xlUp）.Offset（0,15））。复制目标：=目标.Range（“A”&lr1）.End（xlUp）.Offset（1,0）
以
下一页
工作簿（文件名）。关闭
Filename=Dir（）
环
端接头

假设所有工作簿数据表都具有从A列开始的相同结构，则代码将在循环中从单元格A2开始复制每个打开工作簿中的每张工作表到第p列lastrow，然后粘贴到宏所在的工作簿，从A列的最后一个空行开始

如果每个工作簿的每一页上的数据表结构不相同，代码将失败。例如：有一个从A列到D列的数据表，还有一个从B列到E列的数据表

---

如果循环中打开的工作簿中存在空白工作表，则代码也将失败，因为代码不会首先检查循环中打开的工作簿中是否存在空白工作表（或没有数据的表头）。例如：在打开的工作簿Sheet1中有数据，Sheet2为空（或第一行只有标题但没有数据），Sheet3中有数据。

请在阅读注释并可能对复制内容进行一些修改后尝试此代码。代码将根据第1行的宽度确定每张源数据的宽度（假定它包含所有列的标题）。它将根据A列的长度确定所有列的长度（假定A列是最长的）。最后，它假定您不希望所有标题都重复，因此只从每个源工作表的第2行获取数据。所有这些参数都可以根据需要进行设置

子表（） '021

'Const Path As String=“C:\Users\DDC\Desktop\data\” 将文件名设置为字符串 将WsS作为工作表的数据源 Dim WsT作为工作表的数据目标 变暗Rng As范围 将Cl标注为WsS中的最后一列 最后一行的尺寸Rl（交替WsS和WsT）

“这样速度更快，但你看不到发生了什么
Application.ScreenUpdating=False
Set WsT=ThisWorkbook.Worksheets（“Sheet1”）
FileName=Dir（路径&“*.xls*”）
文件名“”时执行此操作
工作簿。打开文件名：=路径和文件名，只读：=真
对于ActiveWorkbook.工作表中的每个WsS
与WsS
'这将在第#1行中查找最后使用的列
'将不会复制此列表右侧的列
'调整行数以适应
Cl=.Cells（1，.Columns.Count）.End（xlToLeft）.Column
'这将在列A中查找最后使用的行
'此下的行（在其他列中）将不会被复制
'调整列名以适应
Rl=.Cells（.Rows.Count，“A”）.End（xlUp）.Row
'要复制的范围将从第2行开始，包括第1行
“假定其中包含标题
'调整行数以适应
设置Rng=.Range（.Cells（2，1），.Cells（Rl，Cl））
Rl=WsT.Cells（WsT.Rows.Count，“A”）.End（xlUp）.行+1
Rng.Copy Destination:=WsT.Cells（Rl，1）
以
下一个WsS
工作簿（文件名）。关闭保存更改：=False
FileName=Dir（）
环
Application.ScreenUpdating=True

端接头

---

您的请求没有提到每个源工作簿中有多少张工作表，但您编写了所有工作表的副本，因此我的工作表也是如此。实际上，每个工作簿中可能只有一张工作表。在这种情况下，“全部”表示1。但如果也有空工作表，“全部”可能意味着将有从空白工作表复制的空白行。我没有为此做准备。

@BigBen，哎呀。。。你说得对。我现在更改代码。感谢您的更正，BigBen。您应该给出您的工作表中有哪些合并代码和数据以及您想要合并的示例。那么这仍然是一个很难回答的问题。否则，这几乎是不可能回答的，因为在VBA中合并几乎是简单的，特别是如果您想对包含任何类型数据的任何类型的工作表进行合并。。。

' it's faster this way but you won't see what's happening
Application.ScreenUpdating = False
Set WsT = ThisWorkbook.Worksheets("Sheet1")

FileName = Dir(Path & "*.xls*")
Do While FileName <> ""
    Workbooks.Open FileName:=Path & FileName, ReadOnly:=True
    For Each WsS In ActiveWorkbook.Worksheets
        With WsS
            ' this finds the last used column in row #1
            ' columns to the right of this will not be copied
            ' adjust row number to suit
            Cl = .Cells(1, .Columns.Count).End(xlToLeft).Column
            ' this finds the last used row in column A
            ' rows below this (in other columns) will not be copied
            ' adjust the column name to suit
            Rl = .Cells(.Rows.Count, "A").End(xlUp).Row
            ' the range to be copied will start at row #2, cluding row #1
            ' which is presumed to contain captions
            ' adjust row number to suit
            Set Rng = .Range(.Cells(2, 1), .Cells(Rl, Cl))

            Rl = WsT.Cells(WsT.Rows.Count, "A").End(xlUp).Row + 1
            Rng.Copy Destination:=WsT.Cells(Rl, 1)
        End With
    Next WsS
    Workbooks(FileName).Close saveChanges:=False
    FileName = Dir()
Loop
Application.ScreenUpdating = True