本教程自用，也适合有一点编程基础的人查阅。课件地址

一： 基础

1.1 If And For

利用if和for来制作工资条和恢复工资表。

PS：插入会导致行序号变化，可以从表尾插入，就不会导致下面的行序号变化了。
删除表或区域也一样，最好倒着删。
如：For i = 100 To 1 Step -1。

Sub 制作工资条()
Dim i As Integer

' 从第3行起，每隔一行插入第一行表头
For i = 3 To 200 Step 2
    ' 如果i行为空，则跳出循环，Range是单元格
    If Range("A" & i) = "" Then
        Exit For
    End If
    
    ' 选择第一行，复制，Rows是行
    Rows("1:1").Select
    Application.CutCopyMode = False
    Selection.Copy
    ' 选中第i行，插入复制的表头
    Range("A" & i).Select
    Selection.Insert shift:=xlDown
    
Next
End Sub


Sub 恢复工资表()
Dim i As Integer

' 从第3行起，递归删除下一行
For i = 3 To 200
    ' 如果i行为空，则跳出循环
    If Range("A" & i) = "" Then
        Exit For
    End If
    
    Range("A" & i).Select
    Application.CutCopyMode = False
    Selection.EntireRow.Delete

Next
End Sub

1.2 操作工作表

1.2.1 Add

Sheets(Sheets.Count)获取最后一张表

Sub 建12个月的表()
Dim i As Integer

For i = 1 To 12
    ' 在最后一张表后面新建一张表
    Sheets.Add after:=Sheets(Sheets.Count)
    ' 最后一张表命名为i月
    Sheets(Sheets.Count).Name = i & "月"
Next
End Sub

1.2.2 Delete

删除表记得加上取消提示框和恢复提示框。

Sub 删除12个月的表()
Dim i As Integer

'取消提示框
Excel.Application.DisplayAlerts = False

For i = 1 To 12
    ' 删除第一张，后面表就变为sheets(1)
    Sheets(2).Delete
Next

' 恢复提示框
Excel.Application.DisplayAlerts = True

End Sub

1.2.3 Copy

Sub 复制表()
Sheets(1).Copy after:=Sheets(Sheets.Count)
End Sub

1.2.4 模板创建日报表

Sub 模板创建31天日报表()
Dim i As Integer

For i = 1 To 31
    ' 复制第一张表
    Sheets(1).Copy after:=Sheets(Sheets.Count)
    ' 最后一张表命名为5月i日
    Sheets(Sheets.Count).Name = "5月" & i & "日"
    ' 表内的e5单元格赋予内容
    Sheets(Sheets.Count).Range("e5") = "2016-5-" & i
Next
End Sub

1.2.5 多表汇总

Sub 多表汇总()
Dim i As Integer
' 把第一张表的B列设为日期
Columns("B:B").Select
Selection.NumberFormatLocal = "yyyy-m-d"

' 从第二张表开始汇总
For i = 2 To Sheets.Count
    ' 把下表的e5内容存到表1的b10单元格内
    Sheets(1).Range("b" & i + 8) = Sheets(i).Range("e5")
    Sheets(1).Range("c" & i + 8) = Sheets(i).Range("e6")
    Sheets(1).Range("d" & i + 8) = Sheets(i).Range("e44")
Next
End Sub

1.3 操作工作簿

1.3.1 For Each

Sub 删除工作簿()
Dim 表 As Worksheet
' 不提示警告框
Application.DisplayAlerts = False
For Each 表 In Sheets
    If 表.Name <> "决不能删" Then
        表.Delete
    End If
Next
Application.DisplayAlerts = True
End Sub

1.3.2 操作文件

Sub 操作文件()
' 关闭屏幕更新，即操作文件时不闪现文件
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' 新建工作簿
Workbooks.Add
' 活动工作簿的第一张表的a2格写入这是我自动创建的
ActiveWorkbook.Sheets(1).Range("a2") = "这是我自动创建的"
' 活动工作簿另存为d:\temp\1.xlsx
ActiveWorkbook.SaveAs Filename:="d:\temp\1.xlsx"
' 关闭工作簿
ActiveWorkbook.Close
' 打开文件d:\temp\1.xlsx
Workbooks.Open Filename:="d:\temp\1.xlsx"
' 活动工作簿的第一张表的a1格写入到此一游
ActiveWorkbook.Sheets(1).Range("a1") = "到此一游"
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

1.3.3 将多个表拆分并另存为多个工作簿

Sub 将多个表拆分并另存为多个工作簿()
Dim sht As Worksheet
' 遍历每一张表
For Each sht In Sheets
    ' 表.copy默认复制当前活动表并新建为一个新工作簿的新表
    sht.Copy
    ' 文件名保存为表名
    ActiveWorkbook.SaveAs Filename:="d:\temp\" & sht.Name & ".xlsx"
    ActiveWorkbook.Close
Next
End Sub

1.4 操作单元格对象

基本函数说明：

1. Cells(10,2) 等同于 B10单元格 等同于 Range("b10")
2. Range("a1").Offset(5,1) 等同于取 a1 单元格下5行、右1列，即 b6
3. Range("a100").End(xlUp) 等同于取 A列从下往上第一个有数据的单元格(若a100本身有数据，则取a100从下往上最后第一个有数据的单元格)
4. Range("a10").EntireRow.Select 等同于选中a10所在单元格那一行
5. Range("a2").Resize(2, 3).Select 等同于选中a2:c3，即选中2行、3列
6. Range("a1").Copy Range("b1") 等同于把a1单元格复制到b1单元格

1.4.1 实际应用1

Sub 合并单元格()
Dim rng As Range
' 合并a1、a2；b1、b2；c1、c2单元格
For Each rng In Range("a1:c1")
    rng.Resize(2, 1).Merge
Next
End Sub

Sub 自动填充()
' 定义rng为单元格格式
Dim rng As Range
' 遍历b2到a列最后一个不为空的单元格的那一行
For Each rng In Range("b2:b" & Range("a65535").End(xlUp).Row)
    ' 若本单元格左边的一格内为男，则本单元格的值为先生
    If rng.Offset(0, -1) = "男" Then
        rng.Value = "先生"
    Else
        rng.Value = "0"
    End If
Next
End Sub

Sub 清空内容()
For i = 2 To Sheets.Count
    ' 清除内容不清除格式
    Sheets(i).Range("a2:z10000").ClearContents
Next
End Sub

Sub 拆分表初版()
Dim i, j, k As Integer
' 调用函数 清空内容()
Call 清空内容
' 遍历所有工作表
For i = 2 To Sheets.Count
    ' 遍历表1的第二行到最后一行
    For j = 2 To Sheet1.Range("a65535").End(xlUp).Row
        ' 若表1的d列值等于表i的名字
        If Sheet1.Range("d" & j) = Sheets(i).Name Then
            ' 表i的单元格最后一行有数据的行号为k
            k = Sheets(i).Range("a65535").End(xlUp).Row
            ' 表1的第j行整行复制到表i的k行的下一行
            Sheet1.Range("d" & j).EntireRow.Copy Sheets(i).Range("a" & k + 1)
        End If
    Next
Next
End Sub

1.4.2 一张表拆分为多张表

Sub 用筛选来拆分表()
Dim i As Integer
For i = 2 To Sheets.Count
    ' 表1的所有行，筛选出第4列D，数据为表名。PS：Criteria1后面是a一
    Sheets(1).Range("a1:f1048").AutoFilter Field:=4, Criteria1:=Sheets(i).Name
    ' 筛选出的表1的所有单元格复制到对应表
    Sheet1.Range("a1:f1048").Copy Sheets(i).Range("a1")
Next
' 关闭筛选
Sheet1.Range("a1:f1048").AutoFilter
End Sub

基本函数：

1. MsgBox "我是弹窗！" 弹出提示框
2. InputBox "你多大了？" 弹出输入框

应用：将一张表的指定列的所有不同的数据拆分为不同的表。

Sub 未重名则新建表(列, sht0)
Dim sht As Worksheet
' 默认k=0
Dim i, k As Integer
Dim irow As Integer ' irow为共多少行
irow = sht0.Range("a65536").End(xlUp).Row
For i = 2 To irow
    k = 0
    For Each sht In Sheets
        ' 遍历表，如果表重名，则k=1，那么不新建
        If sht.Name = sht0.Cells(i, 列) Then
            k = 1
        End If
    Next
    If k = 0 Then ' 没重名
        ' 在最后一张表后面新建表并定义表名
         Sheets.Add(after:=Sheets(Sheets.Count)).Name = sht0.Cells(i, 列)
    End If
Next
End Sub


Sub 拷贝数据(列, sht0)
Dim i As Integer
Dim irow As Integer ' irow为共多少行
irow = sht0.Range("a65536").End(xlUp).Row
Call 未重名则新建表(列, sht0)
For i = 2 To Sheets.Count
    ' 表1的所有行，筛选出第4列D，数据为表名。PS：Criteria1后面是a一
    sht0.Range("a1:z" & irow).AutoFilter Field:=列, Criteria1:=Sheets(i).Name
    ' 筛选出的表1的所有行复制到对应表
    sht0.Range("a1:z" & irow).Copy Sheets(i).Range("a1")
Next
' 关闭筛选
sht0.Range("a1:z" & irow).AutoFilter
End Sub


Sub 拆分数据表完成版()
Dim sht, sht0 As Worksheet
' 将一张表的指定列的所有不同的数据拆分为不同的表
Dim i
i = InputBox("此操作会删除除第一张表外的所有表，如不需要请关闭。那么请问你要拆分第几列(输入数字)？")

' 如果i不是数字或不在范围内，则终止，防止出错
If IsNumeric(i) = False Or i < 1 Or i > 20 Then
    MsgBox ("请输入正确的数字，如4。")
    Exit Sub
End If

' 将i转换为整型
i = Val(i)

' 先备份当前活动表数据到sht0，防止误删
Set sht0 = ActiveSheet

Application.DisplayAlerts = False '关闭提示
' 删除除了第一张表外的所有表
If Sheets.Count > 1 Then
    For Each sht In Sheets
        If sht.Name <> sht0.Name Then
            sht.Delete
        End If
    Next
End If

Call 拷贝数据(i, sht0)
Application.DisplayAlerts = True '打开提示
sht0.Select
End Sub

1.5 事件与典型应用案例

1.5.1 With与选项卡

With可以用于设置单元格格式。

' 对齐方式选项卡
With Selection
        .HorizontalAlignment = xlRight  '水平对齐方式
        .VerticalAlignment = xlCenter   '垂直对齐方式
        .WrapText = False               '自动换行
        .Orientation = 0                '文字方向
        .AddIndent = False              '缩进
        .IndentLevel = 0                '缩进量
        .ShrinkToFit = False            '缩小字体填充
        .ReadingOrder = xlContext       '文字方向
        .MergeCells = False             '合并单元格
    End With

' 字体格式选项卡
 With Selection.Font
        .Name = "华文琥珀"                  '字体
        .Size = 9                           '字号
        .Strikethrough = False              '删除线
        .Superscript = False                '上标
        .Subscript = False                  '下标
        .OutlineFont = False                '大纲字体
        .Shadow = False                     '阴影
        .Underline = xlUnderlineStyleNone   '下划线
        .ColorIndex = xlAutomatic           '字体颜色
        .TintAndShade = 0                   '颜色变深或变浅
        .ThemeFont = xlThemeFontNone        '主题字体
    End With

' 填充色选项卡
 With Selection.Interior
        .Pattern = xlSolid                      '图案样式
        .PatternColorIndex = xlAutomatic        '图案颜色
        .ThemeColor = xlThemeColorDark1         '主体颜色
        .TintAndShade = -4.99893185216834E-02   '颜色变深或变浅
        .Color = 65535                          '填充色
        .PatternTintAndShade = 0                '对象的淡色和底纹图案
    End With

1.5.2 事件

在VBA中，要手动更改单元格或单元格值范围时，可以触发事件驱动的编程。点击查看如何触发事件

常见的事件如下：

工作簿事件|说明
|-|-|
Activate|激活工作薄时
AddinInstall|当工作簿作为加载宏安装时
AddinUninstall|工作簿作为加载宏卸载时
BeforeClose|关闭工作薄前
BeforePrint|打印工作薄（或其中任何内容）之前
BeforeSave|保存工作薄前
Deactivate|工作簿从活动状态转为非活动状态时
NewSheet|在工作簿中新建工作表时
Open|打开工作簿时
PivotTableCloseConnection|在数据透视表关闭与其数据源的连接之后
PivotTableOpenConnection|在数据透视表打开与其数据源的连接之后
SheetActivate|激活任何一张表时
SheetBeforeDoubleClick|双击任何工作表时
SheetBeforeRightClick|鼠标右键单击任一工作表时
SheetCalculate|工作表重新计算时
SheetChange|更改工作表中的单元格时
SheetDeactivate|任一工作表由活动状态转为非活动状态时
SheetFollowHyperlink|单击 Microsoft Excel中的任意超链接时
SheetPivotTableUpdate|数据透视表的工作表更新之后
SheetSelectionChange|工作簿中的数据透视表更新之后
WindowActivate|工作簿的窗口激活时
WindowDeactivate|工作簿的窗口变为非活动状态时
WindowResize|工作簿窗口调整大小时

---

工作表事件	说明
Activate	激活工作表时
Deactivate	工作表从活动状态转为非活动状态时
BeforeDoubleClick	双击工作表前
BeforeRightClick	右键单击工作表时
Calculate	对工作表进行重新计算之后
Change	更改工作表中的单元格，或外部链接引起单元格变化时
FollowHyperlink	单击工作表上的任意超链接时
PivotTableUpdate	在工作簿中的数据透视表更新之后
SelectionChange	工作表上的选定区域发生改变时

---

1.5.3 聚光灯、自动筛选、自动备份

聚光灯效果。

' 在sheet1事件SelectionChange里输入如下代码
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Call 聚光灯
End Sub

Sub 聚光灯()
' 整表无填充色
Cells.Interior.Pattern = xlNone
' 选中的单元格所在行改为黄色
Selection.EntireRow.Interior.Color = 65535
End Sub

自动筛选。

Private Sub Worksheet_Change(ByVal Target As Range)
' 关闭事件触发。事件里一般都要加上，否则一change就触发，会死机
Application.EnableEvents = False
Call 输入条件自动完成筛选
' 打开事件触发
Application.EnableEvents = True
End Sub

Sub 输入条件自动完成筛选()
'清除掉L列及往后的数据
Sheets(1).Range("L1:Q" & Sheets(1).Range("a65536").End(xlUp).Row).Clear
' 筛选表1的第4列，关键词为i2的值
Sheets(1).Range("a1:f" & Sheets(1).Range("a65536").End(xlUp).Row).AutoFilter Field:=4, Criteria1:=Range("i2")
Sheets(1).Range("a1:f" & Sheets(1).Range("a65536").End(xlUp).Row).Copy Range("L1")
' 关闭筛选
Sheets(1).Range("a1:f" & Sheets(1).Range("a65536").End(xlUp).Row).AutoFilter
End Sub

自动备份。

' 在工作薄触发事件中
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
' Format把日期时间数据转换成一个字符串
ThisWorkbook.SaveCopyAs "d:\temp\" & Format(Now(), "yyyymmddhhmmss") & ".xls"
End Sub

1.6 VBA中使用公式

1.6.1 统计人数

Sub 统计人数()
Dim i, k, l, m As Integer
' 遍历工作表
For i = 2 To Sheets.Count
    ' 统计所有工作表中A列中有数据的个数
    k = k + Application.WorksheetFunction.CountA(Sheets(i).Range("a:a")) - 1
    ' 统计所有表中F列为“男”的个数
    l = l + Application.WorksheetFunction.CountIf(Sheets(i).Range("f:f"), "男")
    m = m + Application.WorksheetFunction.CountIf(Sheets(i).Range("f:f"), "女")
Next

Sheets(1).Range("d26") = k
Sheets(1).Range("d27") = l
Sheets(1).Range("d28") = m

End Sub

1.6.2 跨表查询

Sub 跨表查询数据()
' 运行错误，则继续执行出错语句的下面的那句
On Error Resume Next

' 清除d14的姓名数据
Sheets(1).Range("d14").ClearContents

Dim i As Integer
For i = 2 To Sheets.Count
    Sheets(1).Range("d14") = Application.WorksheetFunction.VLookup(Sheets(1).Range("d9"), Sheets(i).Range("a:h"), 5, 0)
    Sheets(1).Range("d16") = Application.WorksheetFunction.VLookup(Sheets(1).Range("d9"), Sheets(i).Range("a:h"), 6, 0)
    Sheets(1).Range("d18") = Application.WorksheetFunction.VLookup(Sheets(1).Range("d9"), Sheets(i).Range("a:h"), 3, 0)
    Sheets(1).Range("d20") = Application.WorksheetFunction.VLookup(Sheets(1).Range("d9"), Sheets(i).Range("a:h"), 8, 0)
    Sheets(1).Range("d22") = Sheets(i).Name
    ' 如果查询到数据，则跳出循环
    If Sheets(1).Range("d14") <> "" Then
        Exit For
    End If
Next

End Sub

1.6.3 Instr 和 Split

Instr用于寻找指定字符；
Split用于切片字符串，分割为字符数组。

Sub 寻找字符()
' 寻找@字符
Range("a1").Value = VBA.Strings.InStr(Range("a2"), "@")
End Sub


Sub 切片()
' 通过指定分隔符，把一个字符串分割成字符串数组，下标从0开始
Range("b2") = Split(Range("a2"), "-")(1)
End Sub

1.6.4 常用的几类VBA函数

With VBA
函数|说明
-|-
.Strings|文本函数
.Math|数学函数
.DateTime|日期时间
.FileSystem|文件信息
.Financial|财务函数
.Information|信息函数
.Interaction|交互函数
End With

---

Sub 转换日期()
' 将20200102转换为2020-01-02
With Sheets(1)
    For i = 2 To .Range("a65536").End(xlUp).Row
        ' DateSerial函数返回包含指定的年、月、日的变量
        .Range("b" & i) = DateSerial(Left(.Range("a" & i), 4), Mid(.Range("a" & i), 5, 2), Right(.Range("a" & i), 2))
    Next
End With
End Sub


Sub 身份证号提取生日()
With Sheets(2)
    For i = 2 To .Range("a65536").End(xlUp).Row
        .Range("b" & i) = DateSerial(Mid(.Range("a" & i), 7, 4), Mid(.Range("a" & i), 11, 2), Mid(.Range("a" & i), 13, 2))
    Next
End With
End Sub

1.7 其他

Sub 批量创建文件夹()
On Error Resume Next
Dim path As String
' //路径是当前文件所在路径的temp文件夹下
myPath = ThisWorkbook.path & "\temp\"
If Dir(myPath) = "" Then         '// 文件夹不存在就建立
    MkDir mypath
End If
For i = 1 To Range("A65536").End(xlUp).Row
    myFilename = myPath & Range("A" & i).Value  '//A列
    If Dir(Name) = "" Then          '// 文件夹不存在就建立
        VBA.MkDir (myFilename)
    End If
Next
End Sub

二： 进阶

2.1 函数和过程

函数有返回值，过程可以无返回值。VBA中直接函数名=返回值。

2.1.1 简单的函数

Function 转美金(x)
    转美金 = x / 6.03 - x * 0.03
End Function

Function 性别(str As String)
    If str = "男" Then
        性别 = "先生"
    ElseIf str = "女" Then
        性别 = "女士"
    End If
End Function

Function 日期转换(str As String)
    日期转换 = DateSerial(Left(str, 4), Mid(str, 5, 2), Right(str, 2))
End Function

Function 截取字符(str As String, str1 As String, i As Integer)
    截取字符 = Split(str, str1)(i - 1)
End Function

2.1.2 创建表通用过程

创建表的过程。

Sub 创建表(str As String)
Dim sht As Worksheet
' 表名重复，则k=1
For Each sht In Sheets
    If sht.Name = str Then
        k = 1
    End If
Next
' 表名不重复，则新建表
If k = 0 Then
    Sheets.Add after:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = str
End If

End Sub

2.1.3 加载宏

• 将有代码的工作簿存为.xla为后缀的文件，存放文档地点默认，即可保存为加载宏。
• 直接点击加载项就可以调用。
• 以后每次打开新的工作簿都可以调用此代码。

2.2 合并多个文件

2.2.1 对象赋值给变量

Set的用法

Sub 对象赋值给变量()
Dim i As Integer
Dim sht As Worksheet
For i = 2 To 5
    ' 用set将对象赋值给变量
    Set sht = Sheets.Add
    sht.Name = Sheet1.Range("a" & i)
Next
End Sub

2.2.2 Dir，路径的使用

Sub dir的用法()
Dim i As Integer
For i = 1 To 5
    ' dir有则返回文件名，无则返回空值;*为通配符，xlsx，xls都可以
    ' 若有n个文件符合，第一个dir加路径返回第一个值，第二个dir直接返回第二个值，
    ' 到第n+1个dir返回空值，n+2个dir返回错误
    If Dir("d:\data\" & Range("a" & i) & ".xls*") = "" Then
        Range("b" & i) = "无此文件"
    Else
        Range("b" & i) = "有文件"
    End If
Next
End Sub

Sub 遍历指定文件夹的文件()
Dim str As String
Dim wb As Workbook
str = Dir("d:\data\*.xls*")
For i = 1 To 100
    ' 遍历打开指定文件夹内的所有xls*文件
    Set wb = Workbooks.Open("d:\data\" & str)

    ' 这里该干嘛干嘛
    
    ' 关闭打开的工作簿
    wb.Close
    ' dir不带参数，返回下一个符合的文件名
    str = Dir
    ' dir返回空，则下一个dir会出错，所有需要跳出循环
    If Dir = "" Then
        Exit For
    End If
Next
End Sub

2.2.3 多文件合并

Sub 多文件合并()
Dim str As String
Dim wb As Workbook
Dim sht As Worksheet
str = Dir("d:\data\*.xls*")
For i = 1 To 100
    Set wb = Workbooks.Open("d:\data\" & str)
    For Each sht In wb.Sheets
        ' 存放在当前活动工作薄的最后一张表
        sht.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = Split(wb.Name, ".")(0) & "_" & sht.Name
    Next
    wb.Close
    str = Dir
    If str = "" Then
        Exit For
    End If
Next
End Sub

2.2.4 查找的标准化写法

Sub 使用查找功能()
' find标准化写法，否则找不到会报错
Dim rng As Range
' find返回一个单元格，赋值于对象
Set rng = Range("d:d").Find(Range("l3"))
' 否否得有，为有数据
If Not rng Is Nothing Then
    Range("m3") = rng.Offset(0, 3)
End If
End Sub

2.3 VBA数组

Sub 使用数组提升运行效率()
Dim i, k
Dim t
Dim str As String
Dim arr()
' 用timer计算程序运行时间
t = Timer
' 数组
arr() = Range("g1:j200000")
str = Range("n5")
For i = 2 To 200000
    If arr(i, 1) = str Then
        k = k + arr(i, 4)
    End If
Next
Range("p5") = k
MsgBox Timer - t
End Sub

Sub 小示例()
Dim arr()
Dim j, i As Integer
j = Range("a65536").End(xlUp).Row - 1
' 重新定义用ReDim
ReDim arr(1 To j)

For i = 1 To j
    arr(i) = Range("b" & i + 1) * Range("c" & i + 1)
Next
' 用自带的函数要加WorksheetFunction.
Range("h3") = Application.WorksheetFunction.Max(arr)
' Match用于返回一个值在指定数组中的位置
Range("h2") = Range("a" & Application.WorksheetFunction.Match(Range("h3"), arr, 0) + 1)
' UBound返回数组上限和LBound下限
MsgBox LBound(arr)
End Sub

Sub 排列组合计算4个数相加等于124704()
Dim i, j, k, l As Integer
Dim arr()
t = Timer
arr = Range("a1:a80")
For i = 2 To 80
    For j = 2 To 80
        For k = 2 To 80
            For l = 2 To 80
                If arr(i, 1) + arr(j, 1) + arr(k, 1) + arr(l, 1) = 124704 Then
                    Range("f3") = arr(i, 1)
                    Range("g3") = arr(j, 1)
                    Range("h3") = arr(k, 1)
                    Range("i3") = arr(l, 1)
                    ' 找到就用goto跳出循环
                    GoTo 100
                End If
            Next
        Next
    Next
Next

100
MsgBox Format(Timer - t, "0.00000")
End Sub

2.4 使用ActiveX控件

2.5 批量插入图片

Public Sub 批量插入图片()

'开始插入图片前，需要将图片名字的跟单元格内容一致
    Application.ScreenUpdating = False
Dim PicName$, pand&, k&, PicPath, i, p, n, PicArr, TitleRow
Dim PicNameCol, PicPath2, PicPath3, TPnameCol, TPCol
    Set PicNameCol = Application.InputBox("请选择图片名称所在列，只能选择单列单元格！", Title:="图片名称所在列", Type:=8)
        '选择的图片名称所在列
    PicCol = PicNameCol.Column '取图片名称所在列列列标
    
    Set TPnameCol = Application.InputBox("请选择图片需要放置的列，只能选择单列单元格！", Title:="图片所在列", Type:=8)
        '选择的图片所在列
    TPCol = TPnameCol.Column '取图片所在列列列标
    
    TitleRow = Val(Application.InputBox("请输入标题行的行数。")) '用户设置总表的标题行数
    If TitleRow < 0 Then MsgBox "标题行必须大于等于零，请重新确认? ": Exit Sub
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False '禁止多选文件夹
       If .Show Then PicPath = .SelectedItems(1) Else: Exit Sub
    End With
    If Right(PicPath, 1) <> "\" Then PicPath = PicPath & "\"

    PicArr = Array(".jpg", ".jpeg", ".bmp", ".png", ".gif") '假定图片格式有5种
    For i = TitleRow + 1 To Cells(Rows.Count, PicCol).End(3).Row
        PicPath2 = PicPath
        ' 图片名字，可自行更改
        PicName = Cells(i, PicCol).Value
        If Len(PicName) <> 0 Then '如果PicName不为空
            PicPath3 = PicPath2 & PicName
            pand = 0
            For p = 0 To UBound(PicArr)'UBound取数组最大下标
                If Len(Dir(PicPath3 & PicArr(p))) Then '如果picpath路径下存在PicName图片
                    ActiveSheet.Shapes.AddPicture PicPath3 & PicArr(p), True, True, _
                    Cells(i, TPCol).Left + 2, Cells(i, TPCol).Top + 1, _
                    Cells(i, TPCol).Width - 4, Cells(i, TPCol).Height -2'left、Width设置跟单元格左右两边的距离
                    pand = 1
                    n = n + 1
                End If
            Next
            If pand = 0 Then k = k + 1
            End If
    Next
    Application.ScreenUpdating = True
    If k <> 0 Then
        MsgBox "图片插入完成！共有" & k & "张图片未找到，请重新确认源文件! "
    Else
        MsgBox "所有图片插入完成！"
    End If
End Sub

2.6 自动按回车

Sub 自动按回车()
    Dim Number, i As Integer
    Application.DisplayAlerts = False
    
    Number = InputBox("请输入次数") * 3 + 3
    
    For i = 1 To Number
        SendKeys "{Enter}"
        t = Now + TimeValue("00:00:02")
        Do Until Now > t
        DoEvents
        Loop
    Next
    Application.DisplayAlerts = True

End Sub

参考

跟着王老师学Excel_VBA