大神帮忙修改下VBA-合并当前目录下所有工作簿的全部工作表【excelhome吧】_百度贴吧
&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&签到排名：今日本吧第个签到，本吧因你更精彩，明天继续来努力！
本吧签到人数：0成为超级会员，使用一键签到本月漏签0次！成为超级会员，赠送8张补签卡连续签到：天&&累计签到：天超级会员单次开通12个月以上，赠送连续签到卡3张
关注：4,827贴子：
大神帮忙修改下VBA-合并当前目录下所有工作簿的全部工作表收藏
Sub 合并当前目录下所有工作簿的全部工作表()Dim MyPath, MyName, AWbNameDim Wb As Workbook, WbN As StringDim G As LongDim Num As LongDim BOX As StringApplication.ScreenUpdating = FalseMyPath = ActiveWorkbook.PathMyName = Dir(MyPath & &\& & &*.xls&)AWbName = ActiveWorkbook.NameNum = 0Do While MyName && &&If MyName && AWbName ThenSet Wb = Workbooks.Open(MyPath & &\& & MyName)t = Wb.Sheets(&门店销售报表&).Cells(Rows.Count, 1).End(xlUp).RowNum = Num + 1With Workbooks(1).ActiveSheet.Cells(.Range(&B65536&).End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4)For G = 1 To Sheets.CountWb.Sheets(G).UsedRange.Copy .Cells(.Range(&B65536&).End(xlUp).Row + 1, 1).Cells(.Range(&B65536&).End(xlUp).Row + 1 - 4, 4).Resize(t) = Format(Left(Wb.Name, InStr(Wb.Name, &.&)), &&)NextWbN = WbN & Chr(13) & Wb.NameWb.Close FalseEnd WithEnd IfMyName = DirLoopRange(&B1&).SelectApplication.ScreenUpdating = TrueMsgBox &共合并了& & Num & &个工作薄下的全部工作表。如下：& & Chr(13) & WbN, vbInformation, &提示&End Sub
低租费、低噪音、低油耗的发电机
合并后日期列乱了，
如何修改，各位大神？
登录百度帐号推荐应用
为兴趣而生，贴吧更懂你。或用VBA合并Excel工作簿_文档库
文档库最新最全的文档下载
当前位置： & 用VBA合并Excel工作簿
用VBA合并Excel工作簿
例如，需要将多个Excel工作簿中的工作表合并到一个工作簿。这里假设需要合并的工作簿在“D:\示例Sub CombineWorkbooks()
Dim strFileName As String
Dim wb As Workbook
Dim ws As Object
'包含工作簿的文件夹,可根据实际修改
Const strFileDir As String = "D:\示例\数据记录\"
Application.ScreenUpdating = False
Set wb = Workbooks.Add(xlWorksheet)
strFileName = Dir(strFileDir & "*.xls*")
Do While strFileName
vbNullString
Dim wbOrig As Workbook
Set wbOrig = Workbooks.Open(Filename:=strFileDir & strFileName, ReadOnly:=True)
strFileName = Left(Left(strFileName, Len(strFileName) - 4), 29)
For Each ws In wbOrig.Sheets
ws.Copy After:=wb.Sheets(wb.Sheets.Count)
If wbOrig.Sheets.Count > 1 Then
wb.Sheets(wb.Sheets.Count).Name = strFileName & ws.Index
wb.Sheets(wb.Sheets.Count).Name = strFileName
wbOrig.Close SaveChanges:=False
strFileName = Dir
Application.DisplayAlerts = False
wb.Sheets(1).Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set wb = Nothing
示例文档下载：
Word文档免费下载：
（共13页）
使用VBA合并多个Excel工作簿的几个例子 MY_计算机软件及应用_IT/计算机_专业资料。vba使用VBA 合并多个 Excel 工作簿的几个例子将许多个工作簿中的工作表合并到一...用VBA合并Excel工作簿_IT/计算机_专业资料。用VBA合并Excel工作簿有许多实现Excel工作簿合并的方法,在《将多个工作簿中的数据合并到一个工作簿》中介绍过合并工作 ...使用VBA 合并多个 Excel 工作簿例如,需要将多个 Excel 工作簿中的工作表合并到一个工作簿。这里假设需要合并的工作簿 在“D:\示例\数据记录\”文件夹中,含有...利用VBA合并工作表与工作薄_计算机软件及应用_IT/计算机_专业资料。1. 合并 Excel 工作簿(workbook) 新建一个空 Excel 工作簿,Alt+F11,插入一个模块,复制以下...有许多实现Excel工作簿合并的方法,在《将多个工作簿中的数据合并到一个工作簿》中介绍过合并工作 例如,需要将多个Excel工作簿中的工作表合并到一个工作簿。这里...用VBA合并Excel工作簿 my_计算机软件及应用_IT/计算机_专业资料。VBAExcel VBA 实战技巧精粹 有许多实现 Excel 工作簿合并的方法,在《将多个工作簿中的数据合并到...EXCEL2007 VBA和合并多个工作薄到一个工作表_计算机软件及应用_IT/计算机_专业资料。EXCEL2007 VBA和合并多个工作薄到一个工作表 ...整理合并 Excel 工作薄中多个工作表如果一个工作薄中存在若干工作表,且工作表的格式一样的话,如果想快速将这些工 作表整合到一个工作表中,则可以使用 VBA 代码...excel VBA 之合并工作簿_计算机软件及应用_IT/计算机_专业资料。excel VBA 之合并工作簿,可自行选择行数 Excel VBA 之合并多个工作簿注意:把需要合并的工作簿...苹果/安卓/wp
积分 191, 距离下一级还需 69 积分
权限: 自定义头衔
道具: 彩虹炫, 涂鸦板, 雷达卡, 热点灯, 金钱卡, 显身卡, 匿名卡下一级可获得
权限: 签名中使用图片
购买后可立即获得
权限: 隐身
道具: 金钱卡, 彩虹炫, 雷达卡, 热点灯, 涂鸦板
无聊签到天数: 141 天连续签到: 1 天[LV.7]常住居民III
& && && &我们在工作中经常会用到的把几个Excel文件合并到一个，或者是把一个Excel文件里的所有Sheet合并到一个Sheet来进行统计。下面分别提供用vba宏来解决这两个问题的方法。
& && &&&方法：打开一个空Excel文件，Alt+F11，插入一个模块，开始写代码：
1、文件合并
Sub MergeWorkbooks()
& & Dim FileSet
& & Dim i As Integer
& & On Error GoTo 0
& & Application.ScreenUpdating = False
& & FileSet = Application.GetOpenFilename(FileFilter:=&Excel 2003(*.xls),*.xls,Excel 2007(*.xlsx),*.xlsx&, MultiSelect:=True, Title:=&选择要合并的文件&)
& & If TypeName(FileSet) = &Boolean& Then
& && &&&GoTo ExitSub
& & End If
& & For Each Filename In FileSet
& && &&&Workbooks.Open Filename
& && &&&Sheets().Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
& & Application.ScreenUpdating = True
2、sheet表合并
Function LastRow(sh As Worksheet)
& & On Error Resume Next
& & LastRow = sh.Cells.Find(what:=&*&, _
& && && && && && && && && & After:=sh.Range(&A1&), _
& && && && && && && && && & Lookat:=xlPart, _
& && && && && && && && && & LookIn:=xlFormulas, _
& && && && && && && && && & SearchOrder:=xlByRows, _
& && && && && && && && && & SearchDirection:=xlPrevious, _
& && && && && && && && && & MatchCase:=False).Row
& & On Error GoTo 0
End Function
Sub MergeSheets()
& & Dim sh As Worksheet
& & Dim DestSh As Worksheet
& & Dim Last As Long
& & Dim shLast As Long
& & Dim CopyRng As Range
& & Dim StartRow As Long
& & Application.ScreenUpdating = False
& & Application.EnableEvents = False
& & '新建一个&汇总&工作表
& & Application.DisplayAlerts = False
& & On Error Resume Next
& & ActiveWorkbook.Worksheets(&汇总&).Delete
& & On Error GoTo 0
& & Application.DisplayAlerts = True
& & Set DestSh = ActiveWorkbook.Worksheets.Add
& & DestSh.Name = &汇总&
& & '开始复制的行号，忽略表头，无表头请设置成1
& & StartRow = 2
& & For Each sh In ActiveWorkbook.Worksheets
& && &&&If sh.Name && DestSh.Name Then
& && && && &Last = LastRow(DestSh)
& && && && &shLast = LastRow(sh)
& && && && &If shLast & 0 And shLast &= StartRow Then
& && && && && & Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))
& && && && && & If Last + CopyRng.Rows.Count & DestSh.Rows.Count Then
& && && && && && &&&MsgBox &内容太多放不下啦！&
& && && && && && &&&GoTo ExitSub
& && && && && & End If
& && && && && & CopyRng.Copy
& && && && && & With DestSh.Cells(Last + 1, &A&)
& && && && && && &&&.PasteSpecial xlPasteValues
& && && && && && &&&.PasteSpecial xlPasteFormats
& && && && && && &&&Application.CutCopyMode = False
& && && && && & End With
& && && && &End If
& && &&&End If
& & Application.GoTo DestSh.Cells(1)
& & DestSh.Columns.AutoFit
& & Application.ScreenUpdating = True
& & Application.EnableEvents = True
载入中......
观点有启发
总评分:&经验 + 100&
学习学习O(∩_∩)O哈！
无限扩大经管职场人脉圈！每天抽选10位免费名额，现在就扫& 论坛VIP& 贵宾会员& 可免费加入
&nbsp&nbsp|
&nbsp&nbsp|
&nbsp&nbsp|
&nbsp&nbsp|
&nbsp&nbsp|
&nbsp&nbsp|
如有投资本站或合作意向，请联系（010-）；
邮箱：service@pinggu.org
投诉或不良信息处理：（010-）
京ICP证090565号
论坛法律顾问：王进律师查看: 4960|回复: 10
VBA中只合并多个工作簿中的sheet1到同一个新表中
阅读权限10
在线时间 小时
做一个命令按钮实现将多个工作簿中的sheet1内容合并到当前工作表中。
求助图.jpg (63.36 KB, 下载次数: 2)
21:10 上传
对excel vba不熟，之前参考过将“多个工作簿中数据合并到同一个工作表中”，但不会改代码。
请求各位老师帮助，万分感谢！
(99.4 KB, 下载次数: 132)
21:12 上传
点击文件名下载附件
阅读权限95
在线时间 小时
打开复制法，速度较慢，但可以保留原表格式，请参考：Sub 打开复制法()
& & Dim f, l&, sh As Worksheet
& & f = Application.GetOpenFilename(fileFilter:=&Excel文件(*.xlsx),*.xlsx&, Title:=&选择Excel文件&, MultiSelect:=True)
& & If TypeName(f) = &Boolean& Then Exit Sub
& & Application.ScreenUpdating = False
& & Set sh = ActiveSheet
& & sh.UsedRange.Offset(2).ClearContents
& & For l = 1 To UBound(f)
& && &&&With GetObject(f(l))
& && && && &.Sheets(1).UsedRange.Offset(2).Copy sh.Range(&a& & Rows.Count).End(xlUp).Offset(1)
& && && && &.Close False
& && && &End With
& & Next
& & Application.ScreenUpdating = True
& & MsgBox &ok&
End Sub
复制代码
阅读权限95
在线时间 小时
ADO法速度较快，但仅复制数值，不保留格式，请参考：Sub ADO法()
& & Dim cnn As Object, SQL$, f, l&
& & f = Application.GetOpenFilename(fileFilter:=&Excel文件(*.xlsx),*.xlsx&, Title:=&选择Excel文件&, MultiSelect:=True)
& & If TypeName(f) = &Boolean& Then Exit Sub
& & Application.ScreenUpdating = False
& & Set sh = ActiveSheet
& & sh.UsedRange.Offset(2).ClearContents
& & For l = 1 To UBound(f)
& && &&&If l = 1 Then
& && && && &Set cnn = CreateObject(&ADODB.Connection&)
& && && && &cnn.Open &Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=& & f(l)
& && && && &SQL = &select * from [sheet1$A2:L]&
& && && && &Range(&a3&).CopyFromRecordset cnn.Execute(SQL)
& && &&&Else
& && && && &SQL = &select * from [Excel 12.0;Database=& & f(l) & &;].[sheet1$A2:L]&
& && && && &Range(&a& & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
& && &&&End If
& & Next
& & cnn.Close
& & Set cnn = Nothing
& & Application.ScreenUpdating = True
& & MsgBox &ok&
End Sub
复制代码
阅读权限95
在线时间 小时
请测试附件
(107.92 KB, 下载次数: 501)
21:41 上传
点击文件名下载附件
阅读权限10
在线时间 小时
& & & & & & & &
zhaogang1960 发表于
请测试附件
非常感谢，两种方法都ok！！！
你太棒了！！
阅读权限20
在线时间 小时
不错，学习了
阅读权限10
在线时间 小时
& & & & & & & &
你好，借用了您写的代码，解决了一个大问题。但是现在我有个问题就是用ADO法中。我想将每一个工作簿的名称也粘贴过来。因为有可能有几个工作簿的同名工作表都没有数据。只有一行0.这样我就没法确定都哪个表返回的是0值。谢谢您
阅读权限20
在线时间 小时
谢谢赵老师，学习了。
阅读权限95
在线时间 小时
你好，借用了您写的代码，解决了一个大问题。但是现在我有个问题就是用ADO法中。我想将每一个工作簿的名称 ...
阅读权限20
在线时间 小时
ADO法速度较快，但仅复制数值，不保留格式，请参考：
请问如何想合并多个工作薄（每个工作薄含有多个工作表）合并到一个新表中，代码应该怎么修改？
辛苦了，谢谢！
最新热点 /1
ExcelHome图书当当网5折来袭，抢、抢、抢！
玩命加载中，请稍候
玩命加载中，请稍候
Powered by
本论坛言论纯属发表者个人意见，任何违反国家相关法律的言论，本站将协助国家相关部门追究发言者责任！ & & 本站特聘法律顾问：徐怀玉律师 李志群律师}