作者：绿色风
分类：
时间：2022-08-17
浏览：143
楼主
kevinchengcw |
Q: 如何将前缀名相同，后面为小括号括起的数字组成的工作表导出到新的同一工作簿中？
A: 对于诸如sheet1，sheet1(1)，sheet1(2)，sheet2，sheet2(1)，sheet2(2)这样的工作表，在导出时想将以sheet1开头的工作表导出到同一工作簿中，而以sheet2开头的工作表导出到另一个工作簿中，可以使用如下代码：- Sub test()
- Dim Wb As Workbook
- Dim Ws As Worksheet
- Dim Dic, Arr
- Dim N As Integer
- Set Dic = CreateObject("scripting.dictionary") '创建字典项目
- For Each Ws In Worksheets '循环工作簿中的各个工作表
- If InStr(Ws.Name, "(") > 0 Then '如果工作表名中存在左括号，则
- If Dic.exists(Trim(Split(Ws.Name, "(")(0))) Then '如果存在字典左侧内容的字典项目，则
- Dic(Trim(Split(Ws.Name, "(")(0))) = Dic(Trim(Split(Ws.Name, "(")(0))) & vbTab & Ws.Name '将该工作表名以特定字符分隔后串接在对应的item项后
- Else '如果不存在括号左侧的项目，则
- Dic.Add Trim(Split(Ws.Name, "(")(0)), Ws.Name '添加该项目，并以当前工作表名为item项
- End If
- Else '如果工作表名中不存在左括号
- If Dic.exists(Trim(Ws.Name)) Then '如果存在该字典项目，则将当前工作表名以特定字符分隔后串接在对应的item项后面
- Dic(Trim(Ws.Name)) = Dic(Trim(Ws.Name)) & vbTab & Ws.Name
- Else '如果不存在该字典项目，则添加该项目并以工作表名为item项
- Dic.Add Trim(Ws.Name), Ws.Name
- End If
- End If
- Next Ws
- Arr = Dic.keys '将字典的keys赋值给数组
- For N = LBound(Arr) To UBound(Arr) '循环数组各项
- Worksheets(Split(Dic(Arr(N)), vbTab)).Copy '将对应数组项的字典item项的内容依特定字符分割后形成的工作表组合复制（这样会生成新的工作簿并且激活）
- Set Wb = ActiveWorkbook '为方便操作，将活动工作簿指定给变量Wb
- Wb.SaveAs ThisWorkbook.Path & "\" & Arr(N) & ".xls" '指定工作簿的储存路径为当前工作簿所在文件夹，工作簿名为当前数组项的内容
- Wb.Close '关闭该工作簿
- Set Wb = Nothing '清除一下工作簿项目，防止出错
- Next N
- Set Dic = Nothing '清空字典项目
- End Sub
以上代码指定以括号来区分工作表名是否为同一前缀，可通过修改达到其他效果，如指定前几个字符相同为同一组等等。
注：因代码中处理前缀名时加了trim，所以sheet1(1)与sheet1 (1)视为同名。 |
2楼
亡者天下 |
 过来学习一下 |
免责声明
有感于原ExcelTip.Net留存知识的价值及部分知识具有的时间限定性因素，
经与ExcelTip.Net站长Apolloh商议并征得其同意，
现将原属ExcelTip.Net的知识帖采集资料于本站点进行展示，
供有需要的人士查询使用，也慰缅曾经的论坛时代。
所示各个帖子的原作者如对版权有异议，
可与本人沟通提出，或于本站点留言，我们会尽快处理。
在此，感谢ExcelTip.Net站长Apolloh的支持，感谢本站点所有人**绿色风（QQ:79664738)**的支持与奉献，特此鸣谢！
------本人网名**KevinChengCW（QQ:1210618015)**原ExcelTip.Net总版主之一