01.批量创建工作表
Sub NewSht()
Dim shtActive As Worksheet, sht As Worksheet
Dim i As Long, strShtName As String
On Error Resume Next '当代码出错时继续运行
Set shtActive = ActiveSheet
For i = 2 To shtActive.Cells(Rows.Count, 1).End(xlUp).Row
'单元格A1是标题，跳过，从第2行开始遍历工作表名称
strShtName = shtActive.Cells(i, 1).Value
'工作表名强制转换为字符串类型
Set sht = Sheets(strShtName) '当工作簿不存在工作表Sheets(strShtName)时，这句代码会出错，然后……
If Err Then
'如果代码出错，说明不存在工作表Sheets(t)，则新建工作表
Worksheets.Add , Sheets(Sheets.Count)
'新建一个工作表，位置放在所有已存在工作表的后面
ActiveSheet.Name = strShtName '新建的工作表必然是活动工作表，为之命名 Err.Clear
'清除错误状态
End If
Next
shtActive.Activate '重新激活原工作表
End Sub
02.删除全部工作表
Sub DelShet() '删除所有工作表
Dim sht As Worksheet
Application.ScreenUpdating = False '关屏幕刷
新Application.DisplayAlerts = False '关警告信息
On Error Resume Next
For Each sht In Worksheets
sht.Delete '遍历工作表删除
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
03.提取工作表名字
Sub GetShtByVba()
Dim sht As Worksheet, k As Long
Application.ScreenUpdating = False
k = 1
Range('a:b').Clear '清空数据Range('a:a').NumberFormat = '@' '设置文本格式
For Each sht In Worksheets '遍历工作表取表名
k = k + 1
Cells(k, 1) = sht.Name
Next
Range('a1:b1') = Array('工作表名', '是否删除')
Application.ScreenUpdating = True
End Sub
04.删除指定工作表
Sub DelShtByVba()
Dim sht As Worksheet, i As Long, r
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
r = Range('a1').CurrentRegion '数据装入数组r
For i = 2 To UBound(r) '遍历并删除工作表
If r(i, 2) = '删除' Then Worksheets(CStr(r(i, 1))).Delete
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
05.生成带超链接的工作表目录
Sub ml()
Dim sht As Worksheet, i&, strShtName$
Columns(1).ClearContents '清空A列数据Cells(1, 1) = '目录' '第一个单元格写入标题'目录' i = 1 '将i的初值设置为1.
For Each sht In Worksheets '循环当前工作簿的每个工作表
strShtName = sht.Name
If strShtName <> ActiveSheet.Name Then
'如果sht的名称不是当前工作表的名称则开始在当前工作表建立超链接
i = i + 1 '累加工作表数量
ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 1), Address:='', SubAddress:=''' & strShtName & ''!a1', TextToDisplay:=strShtName
'建超链接
End If
Next
End Sub
06.在各个分表创建返回总表的命令按钮
Dim strShtName As String
Sub Mybutton()
Dim sht As Worksheet, btn As Button
On Error Resume Next
For Each sht In Worksheets
With sht
If .Name <> strShtName Then
.Shapes(strShtName).Delete
'删除原有的名称为shtn的按钮，避免重复创建
Set btn = .Buttons.Add(0, 0, 60, 30) '使用add方法在工作表中添加一个按钮控件，add方法语法如下:表达式.Add(left,right,width,height)
'新建按钮
With btn
.Name = strShtName
'命令按钮命名
.Characters.Text = '返回总表' '按钮的文本内容
.OnAction = 'LinkTable'
'指定按钮控件所执行的宏命令
End With
End If
End With
Next
Set btn = Nothing
End Sub
Sub LinkTable()
strShtName = '总表' '指定了返回总表的名字，可以根据实际需要修改为目标表的名称Worksheets(strShtName).Activate
[a1].Select
End Sub
07批量取消工作表的隐藏
Sub unShtVisible()
Dim sht As Worksheet
For Each sht In Worksheets '遍历工作表，设置可见
sht.Visible = xlSheetVisible
Next
End Sub
08按指定名称批量创建工作簿
Sub CreateFiles()
Dim strPath As String, strFileName As String
Dim i As Long, r
On Error Resume Next
With Application.FileDialog(msoFileDialogFolderPicker)
'用户选择文件夹路径
If .Show Then strPath = .SelectedItems(1) Else Exit Sub
'如果用户为选择文件夹则退出程序
End With
If Right(strPath, 1) <> '\' Then
strPath = strPath & '\'
Application.ScreenUpdating = False '取消屏幕刷新
Application.DisplayAlerts = False '取消警告提示，当有重名工作簿时直接覆盖
r = Range('a1:a' & Cells(Rows.Count, 1).End(xlUp).Row) '数据装入数组r
For i = 2 To UBound(r) '标题不要，因此从第2个元素开始遍历数组r
With Workbooks.Add '新建工作簿
.SaveAs strPath & r(i, 1), xlWorkbookDefault
'以指定名称、默认文件类型保存工作簿
.Close True '关闭工作簿
End With
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox '创建完成。'
End Sub
联系客服
