VBA 操作sheet页常用代码

fengyehongWorld

已于 2024-05-04 14:48:09 修改

阅读量295

点赞数 5

分类专栏： # VBA 文章标签： VBA

于 2024-05-01 07:58:00 首次发布

本文链接：https://blog.csdn.net/feyehong/article/details/138323614

版权

VBA 专栏收录该内容

8 篇文章 0 订阅

订阅专栏

参考资料

跟着孙兴华学习Excel VBA 第一季

👉以下所有VBA代码，都来自参考资料中的B站课程。
👉所有整理皆为学习VBA，仅做笔记之用。

一. 批量创建sheet页
二. 批量删除当前sheet页之外的所有sheet
三. 获取所有sheet页的名称
四. 删除指定sheet页
五. 生成带超链接的工作表目录
六. 各个分表创建返回总表的按钮
七. 批量修改sheet页名称
八. 批量取消sheet页的隐藏
九. 汇总各sheet页到总sheet
- 9.1 忽略格式
- 9.2 不忽略格式
十. sheet页排序
十一. sheet页加密解密
- 11.1 加密
- 11.2 解密

一. 批量创建sheet页

VBA代码所在sheet页的A1单元格为标题，A2，A3，A4等单元格的内容为要新建sheet页的名称
shtActive.Cells(Rows.Count, 1).End(xlUp).Row
- Rows.Count：返回工作表的总行数，1 表示第一列。这样可以确保我们在整个第1列中寻找最后一个单元格。
- .End(xlUp)：在当前单元格所在列中向上查找并返回第一个非空单元格的方法。对于第1列来说，它会从底部开始向上查找，直到找到第一个非空单元格。
- .Row：返回找到的单元格所在的行号。

Sub CreatSht()

    Dim shtActive As Worksheet, sht As Worksheet
    Dim i As Long, strShtName As String
    ' 当代码出错时继续运行
    On Error Resume Next
    Set shtActive = ActiveSheet
    
    ' 单元格A1是标题，跳过，从第2行开始遍历sheet页名称
    For i = 2 To shtActive.Cells(Rows.Count, 1).End(xlUp).Row
        
        ' sheet页对象强制转换为字符串类型
        strShtName = shtActive.Cells(i, 1).Value
        
        ' 根据sheet名称获取sheet对象(若不存在该sheet名称的话,会报错,然后被 If Err Then 捕获)
        Set sht = Sheets(strShtName)
        
        ' 如果代码出错，说明不存在工作表Sheet，然后就新建
        If Err Then
            ' 新建一个sheet页，位置放在所有已存在sheet页的后面
            Worksheets.Add , Sheets(Sheets.Count)
            ' 新建的sheet必然是活动的sheet，为之命名
            ActiveSheet.Name = strShtName
            ' 清除错误状态
            Err.Clear
        End If
    Next
    
    ' 重新激活原sheet
    shtActive.Activate
End Sub

二. 批量删除当前sheet页之外的所有sheet

On Error Resume Next：VBA 中用于错误处理的语句，当发生运行时错误时，忽略错误并继续执行下一行代码，而不是中断程序并显示错误消息。

Sub DelShet() 

	' 删除所有工作表
    Dim sht As Worksheet
	' 关屏幕刷新
    Application.ScreenUpdating = False
	' 关警告信息
    Application.DisplayAlerts = False 
    On Error Resume Next
	
    For Each sht In Worksheets
		' 遍历删除sheet
        sht.Delete 
    Next
	
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
	
End Sub

三. 获取所有sheet页的名称

在VBA中，Range 和 Cells 是用于引用 Excel 工作表单元格的两种不同方式

引用方式
- Range：Range("A1") ，Range("A1:B10") 表示范围引用。
- Cells：Cells(row, column)，表示行号和列号，Cells(1, 1) 表示第 1 行第 1 列的单元格。
特性
- Range：可以用来引用任何范围，包括单个单元格、多个单元格、整行、整列或具有特定命名的范围。
- Cells：主要用于引用单个单元格，可以通过行号和列号准确地指定单元格的位置。

Sub GetShtByVba()

    Dim sht As Worksheet, k As Long
    Application.ScreenUpdating = False
    k = 1
    
    ' 清空a列和b列的数据
    Range("A:B").Clear
    ' 设置a列的单元格格式为文本
    Range("A:A").NumberFormat = "@"
    
    ' 遍历各sheet对象,获取sheet页名称
    For Each sht In Worksheets
        ' 行自增长(从A2单元格开始)
        k = k + 1
        ' 将sheet页名称放入单元格内(A1单元格,A2单元格,A3单元格...)
        Cells(k, 1) = sht.Name
    Next
    
    ' 设置A1单元格的内容
    Range("A1") = Array("工作表名")
    Application.ScreenUpdating = True
    
End Sub

四. 删除指定sheet页

Dim a1CurrentRegion：在 VBA 中，变量可以是弱类型或者强类型的。变量 a1CurrentRegion 没有明确指定数据类型，因此它被认为是 Variant 类型的变量。
Variant 类型是一种通用的数据类型，可以存储各种类型的数据，包括数字、文本、日期、数组等。
UBound()：VBA 中的一个函数，用于返回数组的最大索引值。

Sub DelShtByVba()

    Dim sht As Worksheet
	Dim i As Long
	' A1单元格所在的区域的数据对象
	Dim a1CurrentRegion
	
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
	' VBA 中用于错误处理的语句，当发生运行时错误时，忽略错误并继续执行下一行代码，而不是中断程序并显示错误消息。
    On Error Resume Next
	
	' Range("A1").CurrentRegion 是 VBA 中用于获取包含指定单元格的当前区域的方法。
	' 返回一个表示当前区域的 Range 对象，该区域由指定单元格所在的连续区域组成
	' 这个连续区域包括所有具有数据的相邻单元格。
    a1CurrentRegion = Range("a1").CurrentRegion 
	
	' 遍历并删除工作表
    For i = 2 To UBound(a1CurrentRegion)
    	' 如果i行，第2列的值为删除的话
        If a1CurrentRegion(i, 2) = "删除" Then 
        	' 删除i行第1列所对应的sheet页	
			Worksheets(CStr(a1CurrentRegion(i, 1))).Delete
		End If
    Next
	
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
	
End Sub

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

⏹ Dim i&：i& 中的 & 是用来声明数据类型的，表示整数
⏹ Dim strShtName$： strShtName$ 中的 $ 也是用来声明数据类型的，表示字符串。

.Hyperlinks.Add：用于生成超链接的函数
- anchor：指定超链接的锚点，即超链接的位置。
- Address：指定超链接的网址，如果是网页链接则指定网址，如果是文档内链接则为空字符串或省略。
- SubAddress：指定超链接的子地址，即超链接的目标位置。
- TextToDisplay：指定超链接显示的文本。

Sub ml()

    Dim sht As Worksheet
    ' i& 中的 & 是用来声明数据类型的,表示整数
    Dim i&
    ' strShtName$ 中的 $ 也是用来声明数据类型的,表示字符串
    Dim strShtName$
    
    ' 清空A列数据
    Columns(1).ClearContents
    ' 第一个单元格写入标题"目录"
    Cells(1, 1) = "目录"
    ' 将i的初值设置为1.
    i = 1
    
    ' 循环当前工作簿的每个工作表
    For Each sht In Worksheets
    
        ' 获取sheet页的名称
        strShtName = sht.Name
        
        ' 如果sht的名称不是当前工作表的名称则开始在当前工作表建立超链接
        If strShtName <> ActiveSheet.Name Then
        
            ' 累加工作表数量
            i = i + 1
            
            ' 创建超链接,其中末尾处的 _ 表示换行,继续到下一行书写代码
            ActiveSheet.Hyperlinks.Add anchor:=Cells(i, 1), _
            Address:="", _
            SubAddress:="'" & strShtName & "'!a1", _
            TextToDisplay:=strShtName
        End If
    Next
    
End Sub

六. 各个分表创建返回总表的按钮

With ... End With
- 指定一个对象，并在代码块中使用该对象的属性和方法，而无需每次都重复引用该对象。
- 使用了With代码块之后，sht.Name 就可以简写为 .Name 了。
Set btn = .Buttons.Add(0, 0, 60, 30)
- Set 是 VBA 中用于分配对象引用的关键字。
- 上述代码使用了 Set 关键字来分配一个按钮对象给变量 btn。
- 在 VBA 中，当你想要将一个对象赋值给一个变量时，特别是当这个对象是一个对象变量（如按钮、工作表等）时，需要使用 Set 关键字。
- 这是因为对象变量实际上存储的是对象的引用，而不是对象本身的值。

Dim strShtName As String

Sub Mybutton()
    
    Dim sht As Worksheet
    Dim btn As Button
    On Error Resume Next
    
    For Each sht In Worksheets
    
        With sht
            If .Name <> strShtName Then
                
                ' 删除原有的名称为shtn的按钮，避免重复创建
                .Shapes(strShtName).Delete
                ' 使用add方法在工作表中添加一个按钮控件
                ' add方法语法如下:表达式.Add(left,right,width,height)
                Set btn = .Buttons.Add(0, 0, 60, 30)
                
                ' 给新创建的按钮指定属性和对应的宏命令
                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单元格
    [A1].Select
    
End Sub

七. 批量修改sheet页名称

Sub ReNameSht()

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

八. 批量取消sheet页的隐藏

Sub unShtVisible()

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

九. 汇总各sheet页到总sheet

9.1 忽略格式

MsgBox "标题行数不能为负数。", 64, "提示": Exit Sub
- 64表示消息框类型为确定和取消按钮
- Exit Sub表示退出当前的子程序
Dim rng As Range
- Range是一种数据类型，用于表示Excel工作表中的单元格区域。
- 使用Range类型的变量可以实现对Excel中特定区域的操作，比如读取单元格的值、设置单元格的值、合并单元格、调整单元格格式等。
- 可以使用rng.Value来获取rng所表示区域的值，或者使用rng.Select来选中这个区域。
[A1].PasteSpecial Paste:=xlPasteValues
- .PasteSpecial是一个Excel中的方法，它允许你以特定的方式粘贴数据。
- Paste:=xlPasteValues是参数，它指定了要粘贴的内容类型。xlPasteValues是Excel中的一个常量，表示只粘贴数值（不包括格式）。
rng.Offset(titleaRowCount).Copy
- Offset是Range对象的一个方法，用于移动指定范围的位置。偏移后的范围将保持原始范围的大小和形状。
- titleaRowCount是一个整数变量，表示要偏移的行数。
  - 如果titleaRowCount为正数，表示向下偏移；
  - 如果为负数，表示向上偏移。

Sub CollectData()

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

9.2 不忽略格式

Val(InputBox("请输入标题的行数", "提醒", 1))：当用户未进行输入的时候，1的作用是默认值。
.PasteSpecial Paste:=xlPasteFormats
- .PasteSpecial: 这是一个Excel中的方法，用于在粘贴时选择特定的粘贴选项。通过.PasteSpecial方法，可以控制粘贴的内容类型，比如数值、格式、公式等。
- Paste:=xlPasteFormats: 这是.PasteSpecial方法的一个参数，用于指定粘贴的内容类型。xlPasteFormats是Excel中的一个常量，表示只粘贴格式，不包括数值或公式。

Sub CollectDataFromShtFormat()

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

十. sheet页排序

⏹先获取整个Excel中的所有sheet页名称到A列单元格

Sub GetShtName()

    Dim k As Long, sht As Worksheet
    ' 取消屏幕更新
    Application.ScreenUpdating = False
    
    With Columns(1)
        ' 清空A列原有数据
        .ClearContents 
        ' 设置单元格格式为文本
        .NumberFormat = "@" 
    End With
    
    Cells(1, 1) = "目录"
    k = 1
    
    ' 遍历工作表
    For Each sht In ThisWorkbook.Worksheets 
    
        ' 如果sht不等于当前工作表名称
        If sht.Name <> ActiveSheet.Name Then 
            ' 累加工作表个数
            k = k + 1 
            ' 工作表名称写入A列
            Cells(k, 1) = sht.Name 
        End If
    Next
    
    ' 恢复屏幕刷新
    Application.ScreenUpdating = True
    
End Sub

⏹根据需求对A列中的sheet页名称进行排序后，执行下面的代码，将A列中的sheet页名称顺序反映到Excel中

Sub SortSht()

    Dim shtActive As Worksheet, i As Long
    Dim arr, strShtName As String
    On Error Resume Next
    
    ' 关屏幕刷新
    Application.ScreenUpdating = False
    ' 当前表赋值变量shtactive
    Set shtActive = ActiveSheet 
    ' A列数据装入数组arr
    arr = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    
    ' 遍历数组arr
    For i = 2 To UBound(arr) 
    
        strShtName = arr(i, 1)
        ' 指定工作表按顺序排放
        Worksheets(strShtName).Move after:=Worksheets(i - 1)
        
    Next
    
    ' 回到操作表
    shtActive.Select
    ' 恢复屏幕刷新
    Application.ScreenUpdating = True
    
End Sub

十一. sheet页加密解密

11.1 加密

StrPtr(Str)：检查字符串是否为空
vbCrLf ：VBA中的特殊常量，表示换行符（回车加换行）。
vbCr ：表示回车符。

Sub ProtectSht()

    Dim strAds As String, sht As Worksheet
    Dim strKey As String, strTemp As String
    Dim rng As Range, strMsg As String
    ' 已经被保护的sheet页的名称
    Dim strNoShtName As String
    ' 待保护的sheet页的名称
    Dim strYesShtName As String
    On Error Resume Next
    
    ' 获取用户输入的待保护的范围
    strAds = InputBox("请输入单元格保存范围，例如A1:B10." & vbCr _
                                & "可以设置不连续单元格，中间请以逗号分隔。" & vbCr _
                                & "比如A1:B10,D2:D8" & vbCr _
                                & "如果需要全表保护，可以直接确定。", Default:="全表保护")
    
    ' StrPtr函数的作用是判断strAds字符串是否为空
    If StrPtr(strAds) = False Then 
        Exit Sub
    End If
    
    ' 如果用户选择是全表保护的话
    If strAds = "全表保护" Then 
        strAds = Cells.Address
    End If
    
    ' 测试输入的单元格区域是否有效
    Set rng = Range(strAds) 
    If Err Then 
        MsgBox "你输入的单元格区域地址不是正确的格式，请重新操作。": Exit Sub
    End If
    
    ' 第一次输入密码
    strKey = InputBox("请输入保护密码。") 
    If StrPtr(strKey) = False Then 
        Exit Sub
    End If
    
    ' 第二次输入密码
    strTemp = InputBox("请再次输入保护密码。") 
    If StrPtr(strTemp) = False Then 
        Exit Sub
    End If
    
    ' 两次输入的密码进行比较
    If strKey <> strTemp Then 
        MsgBox "你两次输入的密码不一致，系统退出，请重新操作。": Exit Sub
    End If
    
    ' 遍历工作表加密保护
    For Each sht In Worksheets
        With sht
            ' 如果工作表未保护
            If .ProtectContents = False Then 
                ' 全部单元格区域取消锁定
                .Cells.Locked = False 
                ' 需要保护的区域锁定
                .Range(strAds).Locked = True 
                ' 保护工作表，只允许编辑非锁定区域
                .Protect strKey, True, True, True 
                ' 保护成功的工作表名称
                strYesShtName = strYesShtName & "," & .Name 
            Else
                ' 自身已有保护功能的工作表
                strNoShtName = strNoShtName & "," & .Name 
            End If
        End With
    Next
    
    If strYesShtName <> "" Then
        strMsg = "工作表：" & Mid(strYesShtName, 2) & "的" & strAds & "区域保护完成"
    End If
    
    If strNoShtName <> "" Then
         strMsg = strMsg & vbCrLf & "以下工作表自身已有保护，无法再次保护：" & Mid(strNoShtName, 2)
    End If
    
    ' 最后显示提示信息
    MsgBox (strMsg)
    
End Sub

11.2 解密

Sub UnProtct()

    MsgBox "破解提示：当要求输入密码时请点击取消！”"
    Application.DisplayAlerts = False
    On Error Resume Next
    Dim sht As Worksheet
    
    For Each sht In Worksheets
        With sht
            .Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True, AllowUsingPivotTables:=True
            .Protect DrawingObjects:=False, Contents:=True, Scenarios:=False, AllowFiltering:=True, AllowUsingPivotTables:=True
            .Protect DrawingObjects:=True, Contents:=True, Scenarios:=False, AllowFiltering:=True, AllowUsingPivotTables:=True
            .Protect DrawingObjects:=False, Contents:=True, Scenarios:=True, AllowFiltering:=True, AllowUsingPivotTables:=True
            .Unprotect
        End With
    Next
    
    MsgBox "ok"
    
End Sub