Excel VBA常用代码

YAR · 发表于 2023-1-26 18:49:51

注册后推荐绑定QQ，之后方才可以使用下方的“用QQ帐号登录”。

您需要登录才可以下载或查看，没有账号？立即注册

x

001.批量创建工作表.txt

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

YAR · 发表于 2023-1-26 18:51:56

002.删除全部工作表

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

YAR · 发表于 2023-1-26 18:54:10

003.提取工作表名字

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

YAR · 发表于 2023-1-26 19:01:39

004.删除指定工作表

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

YAR · 发表于 2023-1-26 19:04:58

005.生成带超链接的工作表目录

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

YAR · 发表于 2023-1-26 19:06:31

006.在各个分表创建返回总表的命令按钮

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 = "总表"'指定了返回总表的名字，可以根据实际需要修改为目标表的名称，比如“目录”。
'设置变量strShtName为总表的名称，可以根据实际总表的名称做修改
Worksheets(strShtName).Activate
[a1].Select
End Sub

YAR · 发表于 2023-1-26 19:07:57

007.批量提取工作表的名字

Sub GetShtName()
Dim sht As Worksheet, i As Long
i = 1 'i初始值为1
With Columns(1)
      .ClearContents '清除A列内容
      .NumberFormat = "@" '设置单元格格式为文本
End With
Cells(1, 1) = "工作表名称目录"
For Each sht In Worksheets '遍历工作表
      i = i + 1
      Cells(i, 1) = sht.Name '在A列记录工作表名称
Next
End Sub

YAR · 发表于 2023-1-26 19:09:35

008.批量修改工作表的名字

Sub ReNameSht()
Dim strShtName$, sht As Worksheet, i&
On Error Resume Next '当程序运行中出现错误时，继续运行
For i = 2 To Cells(Rows.Count, 1).End(xlup).Row '遍历当前表格A列的数据
strShtName = Cells(i, 1).Value '将表格A列的值，赋予变量strShtName
Worksheets(strShtName).Name = Cells(i, 2).Value '工作表重命名
Next
End Sub

YAR · 发表于 2023-1-26 19:11:51

009.批量取消工作表的隐藏

Sub unShtVisible()
Dim sht As Worksheet
For Each sht In Worksheets '遍历工作表，设置可见
sht.Visible = xlSheetVisible
Next
End Sub

YAR · 发表于 2023-1-26 19:12:58

010.一键汇总各分表数据成总表【不保留分表格式】

Sub CollectData()
Dim Sht As Worksheet, rng As Range, k&, n&
Application.ScreenUpdating = False
'取消屏幕更新
n = Val(InputBox("请输入标题的行数", "提醒"))
If n < 0 Then MsgBox "标题行数不能为负数。", 64, "提示": Exit Sub
'取得用户输入的标题行数，如果为负数，退出程序
Cells.ClearContents
'清空当前表数据
For Each Sht In Worksheets
'遍历工作表
      If Sht.Name <> ActiveSheet.Name Then
      '如果工作表名称不等于当前表名则进行汇总动作……
         Set rng = Sht.UsedRange
         '定义rng为表格已用区域
         k = k + 1
         '累计K值
         If k = 1 Then
         '如果是首个表格，则K为1，则把标题行一起复制到汇总表
            rng.Copy
            [a1].PasteSpecial Paste:=xlPasteValues '仅粘贴数值
         Else
            '否则，扣除标题行后再复制黏贴到总表，只黏贴数值
            rng.Offset(n).Copy
            Cells(ActiveSheet.UsedRange.Rows.Count + 1, 1).PasteSpecial Paste:=xlPasteValues
         End If
      End If
Next
[a1].Activate
Application.ScreenUpdating = True '恢复屏幕刷新
End Sub

账号		自动登录	找回密码
密码			立即注册

[分享] Excel VBA常用代码

注册后推荐绑定QQ，之后方才可以使用下方的“用QQ帐号登录”。

评分

浏览过的版块