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

问题描述 投票:-1回答:2

我有一个像这样的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

此VBA代码将多个Excel合并为具有不同工作表的单个Excel。如果我们有100个Excel,则在一个空单元格上运行此代码会将新的空Excel合并为100张纸。例如,假设我有2个不同的Excel,它们的格式相似(包含相同的标头),每个格式包含10行数据。

我的要求是,运行此代码后,我希望o / p excel仅具有1个工作表,并将20行数据合并到一个工作表中。我不要两张分开的纸。

当前,我正在尝试对95张纸进行同样的操作,如果我必须手动将每张纸复制到主纸中,那么该代码就毫无意义。

excel vba
2个回答
0
投票

也许像这样:

Sub GetSheets()
lr = 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)
.Range("A2", .Range("A" & lr).End(xlUp).Offset(0, 15)).Copy Destination:=target.Range("A" & lr).End(xlUp).Offset(1, 0)
End With
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop
End Sub

假设您所有的工作簿数据表都具有从A列开始的相同结构,该代码将从A2单元格开始的循环中将每个打开的工作簿中的每个工作表复制到P列最后一行,然后粘贴到该宏的工作簿中是从A列的最后一个空白行开始。

如果每个工作簿的每一页上的数据表结构都不相同,则代码将失败。例如:有一个数据表从A列开始到D列,还有另一个数据表从B列开始到E列。


0
投票

请阅读注释,并可能对复制内容进行一些修改后,请尝试使用此代码。该代码将通过第1行的宽度确定每张源数据的宽度(假定它包含所有列的标题)。它将通过A列的长度(假定是最长的列)确定所有列的长度。最后,假定您不希望标题重复出现,因此仅从每个源工作表的第2行获取数据。您可以设置所有这些参数以满足您的需求。

Sub GetSheets()'021

'Const Path As String =“ C:\ Users \ DDC \ Desktop \ data \”昏暗的FileName作为字符串作为工作表的Dim WsS'数据源昏暗的WsT作为工作表'数据目标昏暗范围Dim Cl As Long'WsS中的最后一列Dim Rl As Long'最后一行(交替显示WsS和WsT)

' 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

结束子

您的请求没有提及每个源工作簿中有多少工作表,但是您对所有工作表进行代码复制,因此我的代码也是如此。实际上,每个工作簿中可能只有一个工作表。在这种情况下,“全部”表示1。但是,如果也有空的工作表,则“全部”可能表示将从空白表复制的空白行。我没有为此做准备。

© www.soinside.com 2019 - 2024. All rights reserved.