如何用VBA把一个文件夹中excel的所有工作簿中的表导入到一个工作簿？
[问题点数：100分]
如何用VBA把一个文件夹中excel的所有工作簿中的表导入到一个工作簿？
[问题点数：100分]
不显示删除回复
显示所有回复
显示星级回复
显示得分回复
只显示楼主
相关帖子推荐：
2014年9月 其他开发语言大版内专家分月排行榜第二2012年3月 其他开发语言大版内专家分月排行榜第二2010年5月 其他开发语言大版内专家分月排行榜第二
2013年5月 其他开发语言大版内专家分月排行榜第三
2014年9月 其他开发语言大版内专家分月排行榜第二2012年3月 其他开发语言大版内专家分月排行榜第二2010年5月 其他开发语言大版内专家分月排行榜第二
2013年5月 其他开发语言大版内专家分月排行榜第三
2014年9月 其他开发语言大版内专家分月排行榜第二2012年3月 其他开发语言大版内专家分月排行榜第二2010年5月 其他开发语言大版内专家分月排行榜第二
2013年5月 其他开发语言大版内专家分月排行榜第三
匿名用户不能发表回复！|
每天回帖即可获得10分可用分！小技巧：
你还可以输入10000个字符
(Ctrl+Enter)
请遵守CSDN，不得违反国家法律法规。
转载文章请注明出自“CSDN（www.csdn.net）”。如是商业用途请联系原作者。& && &我有一个工作薄A（“2012年数量月统计”），是按照月统计的产品重量统计（每月一张，现共5张）；现在需要把它们累计统计到另一个工作簿B（“2012年数量统计汇总”）的一张工作表C（“2012年数量统计汇总表”）中。我写了一点VBA，但是只能把工作簿A的第一张工作表复制到工作簿B的表C中，然后就开始出现错误。
(18.46 KB, 下载次数: 219)
20:08 上传
下载次数: 219
& &麻烦大家帮我看看，如何解决，谢谢。
在线时间41 小时经验15 威望0 性别保密最后登录注册时间阅读权限10UID1409888积分15帖子精华0分享0
EH新人, 积分 15, 距离下一级还需 5 积分
积分排行3000+帖子精华0微积分0
Private Sub Worksheet_Activate()
& & Sheets(&xx&).Cells.Copy [a1]
& &End Sub
在线时间214 小时经验305 威望0 性别保密最后登录注册时间阅读权限20UID948072积分305帖子精华0分享0
EH初级, 积分 305, 距离下一级还需 45 积分
积分排行3982帖子精华0微积分0
首先谢谢2楼的解答。这个方案好像只适合在同一个工作簿中的复制。
我的困惑是：要在不同工作簿进行跳转，这个方案就不适合了；因为可能涉及到激活不同工作簿的问题，这个问题我解决不了。
麻烦各位再帮我看看。
在线时间1217 小时经验1535 威望0 性别男最后登录注册时间阅读权限50UID349615积分1535帖子精华0分享0
EH高级, 积分 1535, 距离下一级还需 465 积分
积分排行686帖子精华0微积分0
Private Sub Workbook_Open()
Dim wb1 As Workbook, wb2 As Workbook, ws2 As Worksheet, MyPath As String, i, j As Integer, k
MyPath = ThisWorkbook.Path
my = MyPath & &\2012年数量月统计.xls&
Set wb1 = Workbooks.Open(my)
Cells.Clear
For i = 1 To wb1.Worksheets.Count
h = wb1.Worksheets(i).UsedRange.Count
If Application.Count(wb1.Worksheets(i).UsedRange) && 0 Then
& & j = wb1.Worksheets(i).Range(&A6&).End(xlDown).Row
& & k = ThisWorkbook.Sheets(1).Range(&A65536&).End(xlUp).Row + 1
&&wb1.Sheets(i).Range(&a7:b& & j).Copy ThisWorkbook.Sheets(1).Range(&a& & k)
wb1.Close False
Set wb1 = Nothing
Application.ScreenUpdating = True
助人是一种美德，我需要你的鼓励。
在线时间1347 小时经验767 威望0 性别男最后登录注册时间阅读权限30UID420571积分767帖子精华0分享0
EH中级, 积分 767, 距离下一级还需 333 积分
积分排行1391帖子精华0微积分0
本帖最后由 zhw79 于
09:25 编辑
Set TargetBook = application.ActiveWorkbook '2012年数量统计汇总,此表为当前打开表
Set SourceBook = application.Workbooks.Open(&c:\2012年数量月统计&, , True, , &&)&&'第一位为路径，第五位为密码
然后用在sheet前面加前缀来判别不同的工作簿
SourceBook.Sheets(&xx&).Cells.Copy [a1]
TargetBook.sheet(&xx&).Paste
在线时间214 小时经验305 威望0 性别保密最后登录注册时间阅读权限20UID948072积分305帖子精华0分享0
EH初级, 积分 305, 距离下一级还需 45 积分
积分排行3982帖子精华0微积分0
风云际会6 发表于
Private Sub Workbook_Open()
Dim wb1 As Workbook, wb2 As Workbook, ws2 As Worksheet, MyPath As Strin ...
多谢风云际会6的帮助，经测试，可以用（只是Cells.Clear
还需稍作调整为ThisWorkbook.Sheets(1).Cells.Clear
）。我还要多多领会你的 with wb1语句的用途，解决了我的问题。再次感谢。
在线时间214 小时经验305 威望0 性别保密最后登录注册时间阅读权限20UID948072积分305帖子精华0分享0
EH初级, 积分 305, 距离下一级还需 45 积分
积分排行3982帖子精华0微积分0
zhw79 发表于
Set TargetBook = application.ActiveWorkbook '2012年数量统计汇总,此表为当前打开表
Set SourceBook = a ...
多谢你的帮助，这样处理当前表和待处理表，好好琢磨琢磨。
在线时间79 小时经验68 威望0 性别男最后登录注册时间阅读权限20UID1574242积分68帖子精华0分享0
EH初级, 积分 68, 距离下一级还需 282 积分
积分排行3000+帖子精华0微积分0
本帖最后由 迪尼索斯 于
23:48 编辑
发错帖子了，不好意思。
在线时间9 小时经验16 威望0 性别保密最后登录注册时间阅读权限10UID1198261积分16帖子精华0分享0
EH新人, 积分 16, 距离下一级还需 4 积分
积分排行3000+帖子精华0微积分0
真是藏龙卧虎，高手如云呀！
在线时间9 小时经验16 威望0 性别保密最后登录注册时间阅读权限10UID1198261积分16帖子精华0分享0
EH新人, 积分 16, 距离下一级还需 4 积分
积分排行3000+帖子精华0微积分0
在这个论坛游荡了几年，谢谢陪伴！我真的受益匪浅！！
- 注意：自起，未完成邮箱认证的会员将无法发帖！如何完成邮箱认证？请点击下方“查看”。
关注我们，与您相约微信公众平台！
Copyright 1999 - 2017 Excel Home. All Rights Reserved.本论坛言论纯属发表者个人意见，任何违反国家相关法律的言论，本站将协助国家相关部门追究发言者责任！
Powered by
本站特聘法律顾问：徐怀玉律师 李志群律师 &&“详细”工作表是平时把同事和朋友的联系方式录下来的，现我想只要一打开“简化”工作表，就能自动把“详细”工作表的A3至A列最后一个数据，复制到“简化”工作表的A4中去，把“详细”工作表的C3至C列最后一个数据，复制到“简化”工作表的B4中去......，
17:11 上传
下载次数: 54
8.38 KB, 下载次数: 54
在线时间498 小时经验234 威望0 性别保密最后登录注册时间阅读权限20UID994104积分234帖子精华0分享0
EH初级, 积分 234, 距离下一级还需 116 积分
积分排行3000+帖子精华0微积分0
请老师帮我写代码
在线时间1943 小时经验1269 威望0 性别保密最后登录注册时间阅读权限50UID716555积分1269帖子精华0分享0
EH高级, 积分 1269, 距离下一级还需 731 积分
积分排行831帖子精华0微积分0
Sheets(&详细&).Range(&A3:A& & Sheets(&详细&).range(&a65536&).end(xlup).row).Copy&&Sheets(&简化&).Range(&A4&)
没有做不到，只有想不到
想别人帮助，要求说清楚
在线时间498 小时经验234 威望0 性别保密最后登录注册时间阅读权限20UID994104积分234帖子精华0分享0
EH初级, 积分 234, 距离下一级还需 116 积分
积分排行3000+帖子精华0微积分0
谢谢老师了，试试看
- 注意：自起，未完成邮箱认证的会员将无法发帖！如何完成邮箱认证？请点击下方“查看”。
关注我们，与您相约微信公众平台！
Copyright 1999 - 2017 Excel Home. All Rights Reserved.本论坛言论纯属发表者个人意见，任何违反国家相关法律的言论，本站将协助国家相关部门追究发言者责任！
Powered by
本站特聘法律顾问：徐怀玉律师 李志群律师 &&查看: 3196|回复: 4
阅读权限1UID395598函数0 关最后登录经验24 点在线时间0 小时VBA0 关分享记录好友技巧0 关相册主题段位0 段金币50 个积分24精华0帖子日志注册时间
幼儿园小班, 积分 24, 距离下一级还需 76 积分
金币50 个积分24帖子
我有很多同样格式的excel文件，打算把每一个excel文件里的 第1，第3，第4，第7&&个工作表里面的全部内容（能指定符合条件的内容更好）复制到同一个word 文件里。如何用VBA实现？ 谢谢！
阅读权限22UID346883函数0 关最后登录经验19087 点在线时间1060 小时VBA0 关分享记录好友技巧0 关相册主题段位0 段金币10435 个积分19087精华1帖子日志注册时间
一只大懒猫,只管领路 不管喂奶...
大学助理讲师, 积分 19087, 距离下一级还需 7913 积分
金币10435 个积分19087帖子
新建一个word文档与这些xls文件保存在同一目录。在word文档中使用下面的代码将该目录下所有xls文件的第1，3，4，7个工作表的全部内容逐一复制到该word文档中。Sub test()&&& Set xlapp = CreateObject("Excel.Application")&&& p = ThisDocument.Path & "\"&&& f = Dir(p & "*.xls")&&& x = Array(1, 3, 4, 7)&&& Do&&&&&&& Set b = xlapp.workbooks.Open(p & f)&&&&&&& For i = 0 To 3&&&&&&&&&&& b.sheets(x(i)).usedrange.Copy&&&&&&&&&&& Selection.EndKey Unit:=wdStory&&&&&&&&&&& Selection.PasteAndFormat (wdFormatOriginalFormatting)&&&&&&& Next&&&&&&& b.Saved = True&&&&&&& b.Close&&&&&&& f = Dir&&& Loop Until f = ""&&& Set b = Nothing&&& Set xlapp = NothingEnd Sub
[此贴子已经被作者于 10:56:21编辑过]
阅读权限22UID346883函数0 关最后登录经验19087 点在线时间1060 小时VBA0 关分享记录好友技巧0 关相册主题段位0 段金币10435 个积分19087精华1帖子日志注册时间
一只大懒猫,只管领路 不管喂奶...
大学助理讲师, 积分 19087, 距离下一级还需 7913 积分
金币10435 个积分19087帖子
指定要在粘贴所选的表格单元格时使用的格式。 名称值说明wdChart14将 Microsoft Office Excel 图表粘贴为嵌入的 OLE 对象。wdChartLinked15粘贴 Excel 图表并将其链接到原始 Excel 电子表格。wdChartPicture13将 Excel 图表粘贴为图片。wdFormatOriginalFormatting16保留所粘贴材料的原始格式。wdFormatPlainText22粘贴为无格式的纯文本文字。wdFormatSurroundingFormattingWithEmphasis20使所粘贴文本的格式与周围文本的格式匹配。wdListCombineWithExistingList24将粘贴的列表与邻近的列表合并。wdListContinueNumbering7使粘贴的列表根据文档中的列表继续编号。wdListDontMerge25不支持。wdListRestartNumbering8对粘贴的列表重新进行编号。wdPasteDefault0不支持。wdSingleCellTable6将单个单元格表格粘贴为独立的表格。wdSingleCellText5将单个单元格粘贴为文本。wdTableAppendTable10通过在所选行之间插入粘贴的行，将粘贴的单元格合并到现有的表格中。wdTableInsertAsRows11将粘贴的表格作为行插入到目标表格的两行中间。wdTableOriginalFormatting12粘贴一个追加的表格，而不合并表格样式。wdTableOverwriteCells23粘贴表格单元格并覆盖现有的表格单元格。wdUseDestinationStylesRecovery19使用目标文档中使用的样式。
阅读权限1UID395598函数0 关最后登录经验24 点在线时间0 小时VBA0 关分享记录好友技巧0 关相册主题段位0 段金币50 个积分24精华0帖子日志注册时间
幼儿园小班, 积分 24, 距离下一级还需 76 积分
金币50 个积分24帖子
非常感谢！ 下星期一去试一下效果。
阅读权限1UID715290函数0 关最后登录经验2 点在线时间0 小时VBA0 关分享记录好友技巧0 关相册主题段位0 段金币0 个积分2精华0帖子日志注册时间
幼儿园小班, 积分 2, 距离下一级还需 98 积分
金币0 个积分2帖子
Zipall 发表于
新建一个word文档与这些xls文件保存在同一目录。在word文档中使用下面的代码将该目录下所有xls文件的第1，3 ...
大神，请问如果只是将工作表中打印区域批量复制到word，请问改如何修改代码？跪谢！！！请赐教
最佳答案累计大于500
站长推荐 /1
发果你觉得学习excel好枯燥，怎么也学不会。就来论坛微信平台参与excel闯关游戏吧，好玩的关卡，等你来挑战！！
Powered by本帖最后由 dvdlab 于
13:09 编辑
(34.49 KB, 下载次数: 10)
09:41 上传
下载次数: 10
待导出工作表：
09:46 上传
希望修改代码实现下面目的：
将Sheet1工作表以A2为工作簿名，以B1序列的数字为工作表名另存到新的工作簿中（日报.xls）；以后逐个将B1序列的其它工作表另存并插入到上面的“日报.xls”的工作表中，形成下图所示的工作簿。
09:50 上传
（ 上传附件的代码实现的是工作表另存为以B1序列的数字为名的不同的新工作簿，在此感谢老师帮助），其实这段代码已实现原来想法，但后来考虑生成的文件太多，不便管理，就有了上面的想法，希望各位老师帮忙！原代码如下：Sub 按钮SaveAs_Click()
& & Dim Pah$, Nam$, t, fld
& & With ActiveSheet
& && &&&If Len(.Range(&B1&)) & 0 Then
& && && && &Nam = .Range(&B1&).Value & &.xls&
& && && && &Set fld = CreateObject(&Shell.Application&).BrowseForFolder(0, &请选择文件夹&, 0, &&)
& && && && &If fld Is Nothing Then Exit Sub
& && && && &Pah = fld.Self.Path
& && && && &If Right(Pah, 1) && &\& Then Pah = Pah & &\&
& && && && &Application.ScreenUpdating = False
& && && && &.Copy
& && && && &With ActiveWorkbook
& && && && && & Do While ActiveSheet.Shapes.Count &= 1
& && && && && && &&&ActiveSheet.Shapes(1).Delete
& && && && && & Loop& & '另存后新文件删除控件
& && && && && & ActiveSheet.[B1].Validation.Delete&&'去掉B1数据有效性序列
& && && && && & .ActiveSheet.UsedRange = .ActiveSheet.UsedRange.Value& & '去掉公式
& && && && && & If Len(Dir(Pah & Nam)) Then t = MsgBox(&文件重名,要覆盖吗？&, vbYesNo)
& && && && && &&&If t = vbNo Then .Close: Exit Sub
& && && && && & Application.DisplayAlerts = False
& && && && && & .SaveAs Pah & Nam
& && && && && & Application.DisplayAlerts = True
& && && && && & .Close
& && && && &End With
& && && && &Application.ScreenUpdating = True
& && &&&End If
& & End With
End Sub复制代码
在线时间1297 小时经验1110 威望0 性别保密最后登录注册时间阅读权限50UID2298910积分1110帖子精华0分享0
EH高级, 积分 1110, 距离下一级还需 890 积分
积分排行965帖子精华0微积分0
本帖最后由 jbjbzjb 于
12:59 编辑
代码存在逻辑问题，暂时删除。
代码已作了大的修改：
Sub 另存为()
& & Dim sht As Worksheet, wb As Workbook, theStr$, thePath$, shp As Shape, ans&, theWorksheetsExists As Boolean
& & thePath = ThisWorkbook.Path
& & If Right(thePath, 1) && &\& Then thePath = thePath & &\&
& & Application.ScreenUpdating = False
& & Application.ShowWindowsInTaskbar = False
& & For Each sht In ThisWorkbook.Worksheets
& && &&&If Not theWorksheetsExists Then theWorksheetsExists = True
& && &&&If Not wb Is Nothing Then
& && && && &With wb
& && && && && & sht.Copy after:=.Sheets(.Sheets.Count)
& && && && && & For Each shp In ActiveSheet.Shapes
& && && && && && &&&shp.Delete
& && && && && & Next shp
& && && && && & theStr = sht.Cells(2, 1) & sht.Cells(1, 2)
& && && && && & On Error Resume Next
& && && && && & ActiveSheet.Name = theStr
& && && && && & On Error GoTo 0
& && && && &End With
& && &&&Else
& && && && &sht.Copy
& && && && &With ActiveWorkbook
& && && && && & For Each shp In ActiveSheet.Shapes
& && && && && && &&&shp.Delete
& && && && && & Next shp
& && && && && & theStr = sht.Cells(2, 1) & sht.Cells(1, 2)
& && && && && & On Error Resume Next
& && && && && & ActiveSheet.Name = theStr
& && && && && & On Error GoTo 0
& && && && &End With
& && && && &Set wb = ActiveWorkbook
& && &&&End If
& & Next sht
& & If Not theWorksheetsExists Then GoTo The_Exit
& & Application.DisplayAlerts = False
& & If Dir(thePath & &日报.xls&) && && Then
& && &&&Application.ScreenUpdating = True
& && &&&ans = MsgBox(&目标工作簿已存在，您要覆盖吗？&, vbYesNoCancel + vbDefaultButton1 + vbExclamation, &警告&)
& && &&&Select Case ans
& && && && &Case vbYes
& && && && && & Application.DisplayAlerts = False
& && && && && & On Error Resume Next
& && && && && & wb.SaveAs Filename:=thePath & &日报.xls&
& && && && && & Application.DisplayAlerts = True
& && && && && & If Err.Number && 0 Then
& && && && && && &&&On Error GoTo 0
& && && && && && &&&wb.Close SaveChanges:=False
& && && && && && &&&Application.ScreenUpdating = True
& && && && && && &&&Application.ShowWindowsInTaskbar = True
& && && && && && &&&MsgBox &保存工作簿“日报.xls”时出现意外错误！& & vbNewLine & vbNewLine & &提示：请检查待保存的目标工作簿是否正处于打开状态！若是，请先关闭该工作簿。&, vbCritical, &错误&
& && && && && && &&&GoTo The_Exit
& && && && && & End If
& && && && && & On Error GoTo 0
& && && && && & MsgBox &“已生成日报.xls”工作簿&, vbInformation, &信息&
& && && && &Case vbNo
& && && && && & wb.Close SaveChanges:=False
& && && && && & Application.ScreenUpdating = True
& && && && && & Application.ShowWindowsInTaskbar = True
& && && && &Case vbCancel
& && && && && & Application.ScreenUpdating = True
& && && && && & Application.ShowWindowsInTaskbar = True
& && &&&End Select
& & Else
& && &&&On Error Resume Next
& && &&&wb.SaveAs Filename:=thePath & &日报.xls&
& && &&&If Err.Number && 0 Then
& && && && &On Error GoTo 0
& && && && &wb.Close SaveChanges:=False
& && && && &Application.ScreenUpdating = True
& && && && &Application.ShowWindowsInTaskbar = True
& && && && &MsgBox &保存工作簿“日报.xls”时出现意外错误！& & vbNewLine & vbNewLine & &提示：请检查待保存的目标工作簿是否正处于打开状态！若是，请先关闭该工作簿。&, vbCritical, &错误&
& && && && &GoTo The_Exit
& && &&&End If
& && &&&On Error GoTo 0
& && &&&MsgBox &“已生成日报.xls”工作簿&, vbInformation, &信息&
& & End If
The_Exit:
& & Set wb = Nothing
End Sub
在线时间136 小时经验42 威望0 性别保密最后登录注册时间阅读权限20UID975243积分42帖子精华0分享0
EH初级, 积分 42, 距离下一级还需 308 积分
积分排行3000+帖子精华0微积分0
还是非常感谢！
在线时间1297 小时经验1110 威望0 性别保密最后登录注册时间阅读权限50UID2298910积分1110帖子精华0分享0
EH高级, 积分 1110, 距离下一级还需 890 积分
积分排行965帖子精华0微积分0
dvdlab 发表于
还是非常感谢！
代码已重新修改，见原2楼。
在线时间136 小时经验42 威望0 性别保密最后登录注册时间阅读权限20UID975243积分42帖子精华0分享0
EH初级, 积分 42, 距离下一级还需 308 积分
积分排行3000+帖子精华0微积分0
本帖最后由 dvdlab 于
14:01 编辑
jbjbzjb 发表于
代码已重新修改，见原2楼。说仔细些；
谢谢！刚才我试了，还不是我期望的结果，在保存第一个工作表后，相应生成“日报.xls”工作簿，里面有“日报1工作表”；当我再保存第二个工作表时，提示已生成“日报工作簿”，保存后检查“日报工作簿”上只有“日报2工作表”，而不是同时包含“日报1工作表”和“日报2工作表”.。
即不能把多个工作表逐个的保存到一个工作簿中。
在线时间1297 小时经验1110 威望0 性别保密最后登录注册时间阅读权限50UID2298910积分1110帖子精华0分享0
EH高级, 积分 1110, 距离下一级还需 890 积分
积分排行965帖子精华0微积分0
本帖最后由 jbjbzjb 于
13:25 编辑
上你真实的附件，Excel 2003版本的！
咋个简单的代码到你手里运行就出现这问题那问题哪？
补：“覆盖刚刚生成的工作簿”什么意思？“上一个保存过的工作表也同时没了”又是什么意思？表述不清。
警告：你下载的代码是最新的吗？我把代码更新了总计3次，事实上，后面2次跟你说的问题应该关系不大，而第1次（即最早的那次）估计你根本没复制到。不管怎样，你先尝试重新复制2楼的代码试试，经确认后，再反映问题。
在线时间136 小时经验42 威望0 性别保密最后登录注册时间阅读权限20UID975243积分42帖子精华0分享0
EH初级, 积分 42, 距离下一级还需 308 积分
积分排行3000+帖子精华0微积分0
jbjbzjb 发表于
上你真实的附件，Excel 2003版本的！
咋个简单的代码到你手里运行就出现这问题那问题哪？
我是在2010版本的exce，l难道不支持这些代码？&&原来的代码运行在2010没问题，现在考虑用2010通用性较强。
在线时间1297 小时经验1110 威望0 性别保密最后登录注册时间阅读权限50UID2298910积分1110帖子精华0分享0
EH高级, 积分 1110, 距离下一级还需 890 积分
积分排行965帖子精华0微积分0
dvdlab 发表于
我是在2010版本的exce，l难道不支持这些代码？&&原来的代码运行在2010没问题，现在考虑用2010通用性较强。 ...
把 Dir(thePath & &日报.xls&) 改成“日报.xlsx”试试。
另：本人没高版本Excel，不知你问题究竟出在何处，猜测而已，估计不顶用。你问有高版本的吧。
在线时间136 小时经验42 威望0 性别保密最后登录注册时间阅读权限20UID975243积分42帖子精华0分享0
EH初级, 积分 42, 距离下一级还需 308 积分
积分排行3000+帖子精华0微积分0
一直没能改好代码？不得已把这个帖子再捞一下。希望老师帮忙
在线时间153 小时经验51 威望0 性别保密最后登录注册时间阅读权限20UID2754009积分51帖子精华0分享0
EH初级, 积分 51, 距离下一级还需 299 积分
积分排行3000+帖子精华0微积分0
您写的这个代码正是我需要的，但是我想把它转换为我自己的不太会弄！能不能和我说下哦
- 注意：自起，未完成邮箱认证的会员将无法发帖！如何完成邮箱认证？请点击下方“查看”。
关注我们，与您相约微信公众平台！
Copyright 1999 - 2017 Excel Home. All Rights Reserved.本论坛言论纯属发表者个人意见，任何违反国家相关法律的言论，本站将协助国家相关部门追究发言者责任！
Powered by
本站特聘法律顾问：徐怀玉律师 李志群律师 &&}