我有一个像这样的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张纸进行同样的操作,如果我必须手动将每张纸复制到主纸中,那么该代码就毫无意义。
也许像这样:
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列。
请阅读注释,并可能对复制内容进行一些修改后,请尝试使用此代码。该代码将通过第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。但是,如果也有空的工作表,则“全部”可能表示将从空白表复制的空白行。我没有为此做准备。