如何利用字典判断工作表是否存在并创建不存在的工作表？

楼主 kevinchengcw	Q: 如何利用字典判断工作表是否存在并创建不存在的工作表？ A: 有些情况下我们在创建文件列表清单时会需要判断不存在的工作表并创建它，这里引用一个提问的例子演示如何用字典快速高效的实现方法来代替以往通过循环判断的方式，示例代码如下： Sub test() Dim Dic, FSO, TXT, N&, I%, Str$, mDir$, Arr, Arr2, WS As Worksheet Set Dic = CreateObject("scripting.dictionary") '创建字典项目 For Each WS In Worksheets '循环各个工作表 With WS Dic.Add .Name, "" '将表名添加到字典中 .Rows("3:" & .Rows.Count).ClearContents '将循环到的工作表的原数据区清空（本例的需要） End With Next WS mDir = ThisWorkbook.Path & "\" '经常引用的路径设置个变量来取代 With CreateObject("wscript.shell") '利用wscript创建当前文件目录下的文件及文件夹列表（注意：利用了一个等待功能，即等待列表建立完成才继续执行下面的代码） .Run "cmd.exe /c dir """ & mDir & "."" /s /b>""" & mDir & "list.txt""", 0, 1 End With Set FSO = CreateObject("scripting.filesystemobject") '创建FSO对象，用于操作文件清单列表文本文件 If Dir(mDir & "list.txt") <> "" Then '如果文件清单列表已存在，则执行下述操作 Set TXT = FSO.opentextfile(ThisWorkbook.Path & "\list.txt") '利用fso对象打开列表文件 Do While Not TXT.atendofstream '循环读取列表中的每行 Str = TXT.readline If InStr(Str, "\") > 0 Then '如果含有路径分隔符"\"，则进行下述操作 Arr = Split(Str, "\") '将路径依分隔符分割放入数组中 If Arr(UBound(Arr) - 1) <> Split(ThisWorkbook.Path, "\")(UBound(Split(ThisWorkbook.Path, "\"))) And InStr(Arr(UBound(Arr)), ".") > 0 Then '如果当前行的文件或文件夹的上层文件夹不等于当前工作簿的上层文件夹且文件名中有"."存在，则执行下述操作 Arr2 = Split(Split(Arr(UBound(Arr)), ".")(0), " ") '将文件名去掉扩展名后依空格分割放入数组2中 If Not Dic.exists(Arr(UBound(Arr) - 1)) Then '如果字典中不存在当前文件上层目录名的工作表名，说明当前工作簿没有该工作表，则进行创建 Worksheets(Worksheets.Count).Copy after:=Worksheets(Worksheets.Count) '将最后一个工作表复制一份放到工作表最后 With ActiveSheet '复制的工作表会被激活，所以我们对进行相关设置 .Name = Arr(UBound(Arr) - 1) '命名为上层目录的名字 .[a1] = Arr(UBound(Arr) - 1) '标题行也设置为上层目录的名字 .Rows("3:" & .Rows.Count).ClearContents '清空原有数据区 End With Dic.Add Arr(UBound(Arr) - 1), "" '把已创建的工作表名添加到字典，防止重复添加出错 End If With Worksheets(Arr(UBound(Arr) - 1)) '对创建后的工作表进行数据写入操作 With .Cells(.Rows.Count, 2).End(3) '获取关键列B列数据最后一行数据的位置，并对相应数据位置写入对应数据 .Offset(1, -1) = .Offset(1, 0).Row - 2 .Offset(1, 0) = Arr2(0) .Offset(1, 2) = Arr2(1) End With .Hyperlinks.Add .Cells(.Rows.Count, 2).End(3).Offset(0, 1), Str, "", Arr2(2), Arr2(2) '对B列当前对应行插入超链接 End With End If End If Loop TXT.Close '关闭列表文件 Set TXT = Nothing '清空项目 Kill mDir & "list.txt" '删除列表文件 End If Set FSO = Nothing '清空FSO项目 Set Dic = Nothing '清空字典项目 MsgBox "处理完成" '显示提示信息 End Sub 注：以上代码系根据提问者提供的文件特征所做，判断方式并不通用。
2楼 yilaobiao	您提供的代码可以用，也很方便，但序号是从0开始编号，个人认为如果能从1开始编号就更好些。
3楼 yilaobiao	不好意思，是我理解错了，要先把表格设定好，就是从1开始编号。经过实验您编制的宏很好用。谢谢。
4楼 yilaobiao	根据使用，想提一个建议，您给的代码就是会删除其他表格上以设置和输入的数据，能否不删除指定工作表的数据和设置？
5楼 wqfzqgk	看了，没感觉，呵呵
6楼 yilaobiao	我的意思是，做好目录前，目录工作簿里就有几个表格（比如：表一、表二……），表格上也有数据，和以后生成的目录无关，我的意思是生成目录时，不要删除表一、表二……中的数据。谢谢
7楼 yilaobiao	我把文件发给你，工作簿中已有三张工作表：联系人、单位人员登记薄、常用电话号码。我希望在生成目录时不要删除这三张工作表的数据，麻烦你了，谢谢文电目录.rar
8楼 yilaobiao	kevinchengcw：您这些天是不是好忙？没有时间看我发过来的附件？如果您忙的话，那就不打扰您了，如果您有时间的话，就麻烦您过目一下哦。不过您以前发过来的代码对我用处好大，解决我我工作中不少问题，可惜我不懂代码，只有用“拿来”主义，要不我就不会一而再再而三麻烦您了。谢谢您了
9楼 kevinchengcw	Sub test() Dim Dic, FSO, TXT, N&, I%, Str$, mDir$, Arr, Arr2, WS As Worksheet Set Dic = CreateObject("scripting.dictionary") For Each WS In Worksheets With WS Dic.Add .Name, "" If .Name <> "联系人" And .Name <> "单位人员登记薄" And .Name <> "常用电话号码" Then .Rows("3:" & .Rows.Count).ClearContents End With Next WS mDir = ThisWorkbook.Path & "\" With CreateObject("wscript.shell") .Run "cmd.exe /c dir """ & mDir & "."" /s /b>""" & mDir & "list.txt""", 0, 1 End With Set FSO = CreateObject("scripting.filesystemobject") If Dir(mDir & "list.txt") <> "" Then Set TXT = FSO.opentextfile(ThisWorkbook.Path & "\list.txt") Do While Not TXT.atendofstream Str = TXT.readline If InStr(Str, "\") > 0 Then Arr = Split(Str, "\") If Arr(UBound(Arr) - 1) <> Split(ThisWorkbook.Path, "\")(UBound(Split(ThisWorkbook.Path, "\"))) And InStr(Arr(UBound(Arr)), ".") > 0 Then Arr2 = Split(Split(Arr(UBound(Arr)), ".")(0), " ") If Not Dic.exists(Arr(UBound(Arr) - 1)) Then Worksheets(Worksheets.Count).Copy after:=Worksheets(Worksheets.Count) With ActiveSheet .Name = Arr(UBound(Arr) - 1) .[a1] = Arr(UBound(Arr) - 1) .Rows("3:" & .Rows.Count).ClearContents End With Dic.Add Arr(UBound(Arr) - 1), "" End If With Worksheets(Arr(UBound(Arr) - 1)) With .Cells(.Rows.Count, 2).End(3) .Offset(1, -1) = .Offset(1, 0).Row - 2 .Offset(1, 0) = Arr2(0) .Offset(1, 2) = Arr2(1) End With .Hyperlinks.Add .Cells(.Rows.Count, 2).End(3).Offset(0, 1), Str, "", Arr2(2), Arr2(2) End With End If End If Loop TXT.Close Set TXT = Nothing Kill mDir & "list.txt" End If Set FSO = Nothing Set Dic = Nothing MsgBox "处理完成" End Sub 这个不会删除了
10楼 yilaobiao	谢谢您的帮助，你帮我解决了大问题了，十二万分的感谢
11楼 jlf2003	不错，我也学习了！