Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 2150|回复: 5

[已解决]求助:合并所有工作簿中所有 ...

[复制链接]
发表于 2013-11-17 09:04 | 显示全部楼层 |阅读模式
求助:合并所有工作簿中所有工作表并在A、B列加上复制工作簿名称和工作表标签。谢谢!.zip (18.15 KB, 下载次数: 16)
excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2013-11-17 10:12 | 显示全部楼层
你这个题,以前不是有写过类似的代码嘛?
回复

使用道具 举报

发表于 2013-11-17 10:14 | 显示全部楼层
不建议把所有工作簿里的工作表合并到一个工作表里,1+1有可能小于1,也有可能大于1的,到时代码出了错,你又要来折腾一次。
回复

使用道具 举报

 楼主| 发表于 2013-11-17 10:17 | 显示全部楼层
hwc2ycy 发表于 2013-11-17 10:14
不建议把所有工作簿里的工作表合并到一个工作表里,1+1有可能小于1,也有可能大于1的,到时代码出了错,你又 ...

不会再来“折腾”的。
回复

使用道具 举报

 楼主| 发表于 2013-11-17 10:18 | 显示全部楼层
hwc2ycy 发表于 2013-11-17 10:12
你这个题,以前不是有写过类似的代码嘛?

与以往的不同,请按现在的附件的格式设计。谢谢!
回复

使用道具 举报

发表于 2013-11-17 11:03 | 显示全部楼层    本楼为最佳答案   
  1. Sub merge()
  2.     ActiveSheet.UsedRange.Clear
  3.     Range("a1:b1").Value = Array("工作簿", "工作表")
  4.     Dim strPath As String, strFile As String
  5.     Dim wb As Workbook
  6.     Dim sht As Worksheet
  7.     Dim i As Long

  8.     strPath = ThisWorkbook.Path & Application.PathSeparator
  9.     strFile = Dir(strPath & "*.xls")
  10.     Application.ScreenUpdating = False
  11.     Application.DisplayAlerts = False
  12.     Do While Len(strFile)
  13.         If strFile <> ThisWorkbook.Name Then
  14.             '找到文件后执行的操作
  15.             Set wb = GetObject(strPath & strFile)
  16.             For Each sht In wb.Worksheets
  17.                 sht.UsedRange.Copy Cells(Rows.Count, 1).End(xlUp).Offset(1, 2)
  18.                 i = sht.UsedRange.Rows.Count
  19.                 With Cells(Rows.Count, 1).End(xlUp)(2)
  20.                     .Resize(i).Value = wb.Name
  21.                     .Offset(, 1).Resize(i).Value = sht.Name
  22.                 End With
  23.             Next
  24.             wb.Close False
  25.         End If
  26.         strFile = Dir
  27.     Loop
  28.     Application.ScreenUpdating = True
  29.     Application.DisplayAlerts = True
  30.     MsgBox "整理完成"
  31. End Sub
复制代码

评分

参与人数 1 +3 收起 理由
松儿 + 3 很给力!

查看全部评分

回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-28 20:19 , Processed in 0.622106 second(s), 14 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表