|
使用vba，将一个工作簿中的多个工作表拆分为多个工作簿，拆分后的工作簿以工作表名称命名，存档在【当前工作簿目录】下的【拆分工作簿】目录下面。
增加逻辑：
1、如果有隐藏工作表时，弹出输入框，选择是否执行及显示当前隐藏的工作表。
Sub 自动拆分工作表到同一目录中()
'
' 自动拆分工作表 宏
'
' 快捷键: Ctrl+m
'
'把各个工作表以单独的工作簿文件保存在本工作簿所在的文件夹下的“拆分工作簿”文件夹下
'获取活动工作簿所在路径 并判断该路径下是否存在文件夹"拆分工作簿",如果不存在则创建
'遍历活动工作簿中的每个工作表，复制并另存为新的工作簿，工作簿文件名以工作表名称命名
'如果遇到隐藏工作表，则先打开隐藏，复制并另存为后关闭隐藏
'
Application.ScreenUpdating = False '关闭屏幕更新
Dim xpath,isNext As String
Dim sht As Worksheet
xpath = Application.ActiveWorkbook.Path & "\拆分工作簿"
If Len(Dir(xpath, vbDirectory)) = 0 Then MkDir xpath '如果文件夹不存在，则新建文件夹
For Each sht In Worksheets
If sht.Visible = False Then
'MsgBox "有隐藏工作表" & sht.Name
'隐藏工作表是否拆分
isNext = InputBox("1:跳过不处理" & Chr(10) & "2:处理并保持隐藏" & Chr(10) & "3:处理并取消隐藏" & Chr(10) & "空:不输入或其他值则默认不执行", "【" & sht.Name & "】为隐藏工作表,请选择执行方式")
If isNext = 2 Or isNext = 3 Then
sht.Visible = True '取消工作表的隐藏
sht.Copy
ActiveWorkbook.SaveAs FileName:=xpath & "\" & sht.Name & ".xlsx"
ActiveWorkbook.Close
If isNext = 2 Then
sht.Visible = False '恢复工作表的隐藏
End If
End If
ElseIf sht.Visible = True Then
sht.Copy
ActiveWorkbook.SaveAs FileName:=xpath & "\" & sht.Name & ".xlsx"
ActiveWorkbook.Close
End If
Next
'MsgBox "工作簿拆分结束"
Application.ScreenUpdating = True '恢复屏幕更新
End Sub
补充知识点：
VBA中字符换行显示需要使用换行符来完成。下面是常用的换行符
'chr(10) 可以生成换行符
'chr(13) 可以生成回车符
'vbcrlf 换行符和回车符
'vbCr 等同于chr(10)
赾hr(13)
'例：
Sub test3()
MsgBox "我爱" & Chr(10) & "Excel学习"
' MsgBox "我爱你" & Chr(13) & "Excel"
' MsgBox "今天" & vbCrLf & "我是大王"
End Sub
|