如何生成同一文件夹下的所有工作簿内和所有工作表目录

why18 · 发表于 2011-9-27 10:14

单位经常与有关单位有关联数据,每月都把各单位数据做在一个工作簿中,但并非每月各单位都有,故每月工作簿内工作表数量不定,
有时想查找一下一定时段某单位的数据,必须打开每个工作簿查看
想定期对同一文件夹下的文件整理出一个目录文件来,即新生成一个工作簿为目录,其中第一列为文件夹下的工作簿名,第二列为工作簿下的所有工作表名.
请高手帮忙

opiona · 发表于 2011-9-27 10:58

'在文件夹内新建一个表，复制粘贴此代码，运行宏。
Sub OPIONA()
'On Error Resume Next
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Application.ScreenUpdating = False '关闭屏幕刷新
Application.DisplayAlerts = False '关闭提示
If MsgBox("需要操作的数据表是：EXCEL2003 格式，请选择：是！" & Chr(13) & "" & Chr(13) & "需要操作的数据表是：EXCEL2007 格式，请选择：否！", vbYesNo, "北极狐提示！！") = vbYes Then
S = "\*.xls"
ss = 4
Else
S = "\*.xlsx"
ss = 5:
End If
t = Timer '记录开始时间
f = Dir(ThisWorkbook.Path & S) '生成查找EXCEL的目录
n = 2 '开始记录工作簿名和工作表名的开始行
Do While f > " " '在目录中循环
If f <> ThisWorkbook.Name Then '如果不是打开的工作簿
Set xlBook = Workbooks.Open(ThisWorkbook.Path & "" & f) '打开已经存在的EXCEL工件簿文件
For Each sh In xlBook.Worksheets '遍历工作表
Windows(ThisWorkbook.Name).Activate '回到操作主表界面
If n = 2 Then Sheets(1).Cells(1, 1) = "工作簿名": Sheets(1).Cells(1, 2) = "工作表名": '加入标题行
Sheets(1).Cells(n, 1) = Mid(f, 1, Len(f) - ss) '所在工作簿名
Sheets(1).Cells(n, 2) = sh.Name '所在工作表名
n = n + 1
Next
Windows(f).Close (False) '关闭工作簿，不保存
End If
f = Dir
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "一共用时：" & Timer - t & " 秒", , "北极狐提示!!"
End Sub

复制代码

文件夹下的所有工作簿内和所有工作表目录.rar (10.88 KB, 下载次数: 856)

学生甲1 · 发表于 2011-9-27 16:25

二楼想得真全面。学习了！

joyark · 发表于 2011-9-27 20:37

谢谢分享经历。學習了！

why18 · 发表于 2011-9-29 10:16

谢谢二楼opiona，太感谢了

opiona · 发表于 2011-9-29 12:31

数据计算到 2000多行的时候，就提示 vb 什么的就提示选定的区域太大？？？

没有那么多文件，无法测试，你将错误截图发来看看

jizewei · 发表于 2011-11-18 16:41

这个实际工作中好用，不错。

zuiaidh2004 · 发表于 2012-1-31 11:13

路过学习。。。

zuiaidh2004 · 发表于 2012-1-31 11:16

opiona 发表于 2011-9-27 10:58

生成目录好快啊，能否升级为可以修改文件名，设计成四列，原工作簿名-原工作表名，修改为新工作簿名-新工作表名。这样就非常好用。。

左手有把刀 · 发表于 2012-7-31 16:40

走过....拾起....入袋

		自动登录	找回密码
密码			免费注册

[求助] 如何生成同一文件夹下的所有工作簿内和所有工作表目录