Excel中实现多个工作薄内容复制到一个新的工作薄中，求VBA代码 20
要解决的问题是：现在在某个文件夹下只有一个excel文件，这个文件里有多页工作薄，每个工作薄里的内容要复制到新的excel文件的一个工作薄中，注意是一个工作薄中，而且中间...
要解决的问题是：
现在在某个文件夹下只有一个excel文件，这个文件里有多页工作薄，每个工作薄里的内容要复制到新的excel文件的一个工作薄中，注意是一个工作薄中，而且中间不要少行。下面的这段代码可以实现，但是就有一个问题，从第二页工作薄开始，后面的没个工作薄中的第一行都没有复制到。
可能的原因是没有将选择区域下移一行的原因，但不知道该怎么写。请教大侠解决！！！
Sub HuiZong()
Dim myfile, mypath, wb '声明变量
Application.ScreenUpdating = False '关闭屏幕更新
Sheet1.UsedRange.Offset(1, 0).Clear '清除除表头之外的所有内容
mypath = ThisWorkbook.Path '找到当前工作簿的路径
myfile = Dir(mypath & "\*.xls*") '遍历当前文件夹下的Excel文件
i = 1
j = 0
Do While myfile <> "" '当找到的文件不为空时
If myfile <> ThisWorkbook.Name Then '当找到的文件不是当前Excel工作簿时
Set wb = GetObject(mypath & "\" & myfile) '得到dir找到的工作簿的内容，设为wb
Do While i < wb.Worksheets.Count + 1
With wb.Sheets(i) '对找到的工作簿的sheet1进行操作
.UsedRange.Offset(0, 0).Copy Sheet1.Range("A" & Sheet1.UsedRange.Rows.Count) '复制wb的sheet1从第一行的内容开始
End With
i = i + 1
Loop
wb.Close False '关闭wb工作簿且不保存
End If
myfile = Dir '寻找下一个Excel工作簿
Loop
Application.ScreenUpdating = True '恢复屏幕更新
End Sub 展开
现在在某个文件夹下只有一个excel文件，这个文件里有多页工作薄，每个工作薄里的内容要复制到新的excel文件的一个工作薄中，注意是一个工作薄中，而且中间不要少行。下面的这段代码可以实现，但是就有一个问题，从第二页工作薄开始，后面的没个工作薄中的第一行都没有复制到。
可能的原因是没有将选择区域下移一行的原因，但不知道该怎么写。请教大侠解决！！！
Sub HuiZong()
Dim myfile, mypath, wb '声明变量
Application.ScreenUpdating = False '关闭屏幕更新
Sheet1.UsedRange.Offset(1, 0).Clear '清除除表头之外的所有内容
mypath = ThisWorkbook.Path '找到当前工作簿的路径
myfile = Dir(mypath & "\*.xls*") '遍历当前文件夹下的Excel文件
i = 1
j = 0
Do While myfile <> "" '当找到的文件不为空时
If myfile <> ThisWorkbook.Name Then '当找到的文件不是当前Excel工作簿时
Set wb = GetObject(mypath & "\" & myfile) '得到dir找到的工作簿的内容，设为wb
Do While i < wb.Worksheets.Count + 1
With wb.Sheets(i) '对找到的工作簿的sheet1进行操作
.UsedRange.Offset(0, 0).Copy Sheet1.Range("A" & Sheet1.UsedRange.Rows.Count) '复制wb的sheet1从第一行的内容开始
End With
i = i + 1
Loop
wb.Close False '关闭wb工作簿且不保存
End If
myfile = Dir '寻找下一个Excel工作簿
Loop
Application.ScreenUpdating = True '恢复屏幕更新
End Sub 展开
1个回答
展开全部
试一下这个代码：第3行的bt = 1是指标题行有1行；如果标题行有多行，请更改1为实际行数。
将要汇总的文件放到一个单独专门的文件夹中。在此文件夹中新建或打开一个Excel文件作为汇总文件，找一个空白Sheet或者新建一个Sheet存放汇总数据。
然后按“Alt+F11”打开VBA编辑窗口，然后在左侧对应的Sheet上双击，右侧空白处粘贴下面的代码。关闭VBA窗口。然后按“Alt+F8”打开宏窗口，选择刚插入的宏，点击“执行”。
Sub hz()
Dim bt, i, r, c, n, first As Long
bt = 1
Dim f, ff As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ff = fso.getfolder(ThisWorkbook.Path & "\")
For Each f In ff.Files
If f.Name <> ThisWorkbook.Name And Left(f.Name, 2) <> "~$" Then
Workbooks.Open ThisWorkbook.Path & "\" & f.Name
With Workbooks(f.Name)
For i = 1 To .Sheets.Count
If first = 0 Then
c = .Sheets(i).Cells(1, Columns.Count).End(xlToLeft).Column
.Sheets(i).Range("A1").Resize(bt, c).Copy ThisWorkbook.ActiveSheet.Range("A1")
n = bt + 1: first = 1
End If
r = .Sheets(i).Cells(Rows.Count, "A").End(xlUp).Row
.Sheets(i).Range("A" & bt + 1).Resize(r - 1, c).Copy ThisWorkbook.ActiveSheet.Range("A" & n)
n = n + r - bt
Next
End With
Workbooks(f.Name).Close False
End If
Next f
Set fso = Nothing
End Sub
更多追问追答
追问
运行时错误‘1004’：应用程序定义或对象定义错误。
追答
按F8单步执行，看一下是执行到哪一行出错，截个图上来看一下。
已赞过
已踩过<
评论
收起
你对这个回答的评价是？
推荐律师服务：
若未解决您的问题，请您详细描述您的问题，通过百度律临进行免费专业咨询
