VBA

lei 2020-11-07 最后更新于 2025-11-24 约 5569 字阅读时长12 分钟 VBA

VBA ¶

操作工作表 ¶

新建表 ¶

1sub 新建()
2    Sheets.add after:=sheets(sheets.count)
3    sheets(sheets.count).name="工作表" '工作表命名'
4end sub

根据模板生成 ¶

 1Sub 生成()
 2Application.DisplayAlerts = False
 3
 4Dim i As Integer
 5For i = 1 To InputBox("生成工作表个数")
 6    Worksheets(1).Copy after:=Worksheets(Worksheets.Count)
 7    Worksheets(Worksheets.Count).Name = "12月" & i & "日"
 8    Worksheets(Worksheets.Count).Range("A1") = "12月" & i & "日"
 9Next
10Worksheets(1).Select
11Application.DisplayAlerts = True
12End Sub

删除所有工作表 ¶

1Sub 清除()
2Application.DisplayAlerts = False
3Do While Worksheets.Count <> 1
4    Worksheets(Worksheets.Count).Delete
5Loop
6Application.DisplayAlerts = True
7End Sub

根据工作表生成目录 ¶

 1Sub CreateMenu()
 2Sheets.Add(Before:=Sheets(1)).Name = "目录"  '新建一个目录工作表
 3Worksheets("目录").Activate
 4    For i = 2 To Sheets.Count
 5        If Sheets(i).Visible = True Then
 6            Cells(i, 1) = Sheets(i).Name  '将其他工作表名称分别填入单元格中
 7            Cells(i, 1).Select
 8                ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'" & Sheets(i).Name & "'!A1", TextToDisplay:=Cells(i, 1).Value
 9                '创建超链接
10        End If
11    Next i
12End Sub

操作工作簿 ¶

所有工作表另存工作簿 ¶

 1Sub 拆分()
 2Application.ScreenUpdating = False
 3Dim sht As Worksheet
 4For Each sht In Worksheets
 5    sht.Copy
 6    ActiveWorkbook.SaveAs Filename:="C:\Users\lei\Desktop\T\" & sht.Name & ".xlsx"
 7    ActiveWorkbook.Close
 8Next
 9Application.ScreenUpdating = True
10End Sub

操作单元格 ¶

常见代码 ¶

 1[a10]  		'a10单元格，不支持变量'
 2cells(2,3) 	'第二行第三列，只能选择一个格子，支持变量'
 3range("a10")	'a10单元格，应用场景广泛'
 4range("a10").value	'单元格默认属性为 .value，大多情况可以省略'
 5
 6range("a1").offset(10,0) '下移10行，右移0列'
 7range("a1000").end(xlUP).Row	'表示a1000单元格往上第一个有数据的格子的行号，.Row返回单元格行号'
 8
 9range("a10").EntireRow	'a10 单元格所在的整行'
10range("a10").resize(1,4)  '重新选择a10单元格区域大小'
11
12range("a10:f10").copy range("a11")		'将a10:f10区域，复制到a11'
13
14range("a10:f10").Merge	'将a10:f10区域合并'

数据拆分到多表（循环） ¶

 1Sub 拆分()
 2    '工作表建好了情况下，固定列，该段代码仅供参考，通过循环'
 3Dim i, j, k As Integer
 4Call 清空   '调用 清空 这个过程
 5For j = 2 To Sheets.Count
 6    For i = 2 To Sheets(1).Range("a10000").End(xlUp).Row
 7        If Sheets(1).Range("d" & i) = Sheets(j).Name Then
 8            k = Sheets(j).Range("a10000").End(xlUp).Row
 9            Sheets(1).Range("d" & i).EntireRow.Copy Sheets(j).Range("a" & k + 1)
10        End If
11    Next
12Next
13End Sub
14
15Sub 清空()
16    For i = 2 To Sheets.Count
17        Sheets(i).Range("a2:f1000").ClearContents
18    Next
19End Sub

数据拆分到多表（筛选） ¶

 1Sub 拆分()
 2    '工作表建好了情况下，固定列，效率比for循环高很多
 3    Dim i As Integer
 4    Call 清空
 5    For i = 2 To Sheets.Count
 6        Sheets(1).Range("A1:F1048").AutoFilter Field:=4, Criteria1:=Sheets(i).Name
 7        Sheets(1).Range("A1:F1048").Copy Sheets(i).Range("a2")
 8    Next
 9    Sheets(1).Range("A1:F1048").AutoFilter  '''取消筛选
10End Sub
11Sub 清空()
12        For i = 2 To Sheets.Count
13            Sheets(i).Range("a2:f1000").ClearContents
14        Next
15End Sub

数据根据某列拆分建表 ¶

 1Sub 根据某列建表并复制数据()
 2'重点 
 3'1.新建表避免表名重复
 4'2.通过用户输入 根据哪列进行拆分
 5'3.通过筛选将相应的数据拷贝到对应工作表
 6Application.DisplayAlerts = False
 7Dim sht As Worksheet
 8Dim i, irow, j, k As Integer
 9Dim a As Range
10Dim l As Integer '按哪列拆分
11l = InputBox("请输入按哪列拆分（输入数字）")
12irow = Sheets(1).Range("a10000").End(xlUp).Row '数据行
13
14'删除多余工作表
15For j = 2 To Sheets.Count
16    Sheets(Sheets.Count).DrawingObjects.Delete
17Next
18
19'根据列拆分表
20For i = 2 To irow
21    k = 0
22    Set a = Worksheets(1).Cells(i, l)
23    For Each sht In Sheets
24        If sht.Name = a Then
25            k = 1
26        End If
27    Next
28    If k = 0 Then
29        Sheets.Add after:=Sheets(Sheets.Count)
30        Sheets(Sheets.Count).Name = a.Value
31    End If
32Next
33
34'通过筛选复制数据
35For j = 2 To Sheets.Count
36    Sheets(1).Range("a1:f" & irow).AutoFilter field:=l, Criteria1:=Sheets(j).Name   'field:=l 筛选哪一列(这里是变量 l)
37    Sheets(1).Range("a1:f" & irow).Copy Sheets(j).Range("a2")
38Next
39Sheets(1).Range("a1:f" & irow).AutoFilter
40Sheets(1).Select
41Application.DisplayAlerts = True	
42End Sub

合并多个工作表 ¶

 1Sub 合并多表()
 2Dim sht As Worksheet
 3Dim i, j As Integer
 4For Each sht In Sheets
 5    i = Sheets(1).Range("a10000").End(xlUp).Row
 6    j = sht.Range("a10000").End(xlUp).Row
 7    If sht.Name <> Sheets(1).Name Then
 8        sht.Range("a2:f" & j).Copy Sheets(1).Range("a" & i + 1) '最后数据行下面粘贴
 9    End If
10Next
11End Sub

单元格格式 ¶

 1'字体格式选项卡'
 2With Selection.Font
 3    .Name = "华文琥珀"		'字体'
 4    .Size = 9		'字号'
 5    .Strikethrough = False		'删除线'
 6    .Superscript = False		'上标'
 7    .Subscript = False		'下标'
 8    .OutlineFont = False		'大纲字体'
 9    .Shadow = False		'阴影'
10    .Underline = xlUnderlineStyleNone		'下划线'
11    .ColorIndex = xlAutomatic		'字体颜色'
12    .TintAndShade = 0		'字体颜色变深或变浅'
13    .ThemeFont = xlThemeFontNone		'主题字体'
14End With
15
16'填充色选项卡'
17 With Selection.Interior
18    .Pattern = xlSolid		'图案样式'
19    .PatternColorIndex = xlAutomatic	'图案颜色'
20    .ThemeColor = xlThemeColorDark1		'主题颜色'
21    .TintAndShade = 0		'颜色变深或变浅'
22    .Color = 65535		'填充色'
23    .PatternTintAndShade = 0		'对象的单色和底纹图案'
24End With

工作表事件案例1 ¶

1'标亮选中行，工作表事件，当选取发生变化自动执行以下代码'
2Private Sub Worksheet_SelectionChange(ByVal Target As Range)	'选区变换执行'
3    Cells.Interior.Pattern = xlNone
4    With Selection.EntireRow.Interior
5        .Pattern = xlSolid
6        .PatternColorIndex = xlAutomatic
7        .Color = 65535
8    End With
9End Sub

工作表事件案例2 ¶

 1'通过单元格内容筛选某列，并自动更新'
 2Private Sub Worksheet_Change(ByVal Target As Range)	'工作表内容变化执行'
 3    Application.EnableEvents = False    '关闭事件响应，否则此段代码会卡死
 4    Dim i, j As Integer
 5    i = ActiveSheet.Range("a10000").End(xlUp).Row    '数据行数量
 6    j = ActiveSheet.Range("l10000").End(xlUp).Row   '筛选出来的数据行数量
 7    ActiveSheet.Range("l1:q" & j).ClearContents     '清除筛选出来的数据
 8    ActiveSheet.Range("A1:F" & i).AutoFilter Field:=4, Criteria1:=Range("i2")
 9    ActiveSheet.Range("A1:F" & i).Copy ActiveSheet.Range("l1")
10    ActiveSheet.Range("A1:F" & i).AutoFilter
11    Application.EnableEvents = True
12End Sub

工作簿事件案例1 ¶

1'工作簿保存时备份文件'
2Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)	'工作簿保存前触发事件'
3    Dim dateTime As String
4    dateTime = Format(Now(), "mmddhhmmss")  '获取当前时间
5    '保存工作簿时 新建一份副本
6    ThisWorkbook.SaveCopyAs Filename:="G:\code\vba\跟着王佩丰学VBA附件\VBA07\backup\" & dateTime & ".xlsx"
7End Sub

工作簿事件案例2 ¶

 1'制作密码验证表，输入对应的密码显示对应的工作表'
 2Private Sub Workbook_BeforeClose(Cancel As Boolean)	'工作簿关闭之前执行'
 3'隐藏除了登录以外的表'
 4Dim sht As Worksheet
 5For Each sht In Sheets
 6    If sht.Name <> "登录" Then
 7            sht.Visible = xlSheetVeryHidden '隐藏除登录外所有工作表
 8    End If
 9Next
10ActiveWorkbook.Save '保存活动工作簿
11End Sub
12
13Private Sub Workbook_Open() 	'工作簿打开时执行事件
14Dim i As String
15Dim sht As Worksheet
16i = InputBox("请输入密码")
17If "123" = i Then
18    For Each sht In Sheets
19        If InStr(sht.Name, "张三") <> 0 Then    '工作表名包含张三时
20            sht.Visible = xlSheetVisible    '显示工作表
21        End If
22    Next
23ElseIf "456" = i Then
24    For Each sht In Sheets
25        If InStr(sht.Name, "李四") <> 0 Then
26            sht.Visible = xlSheetVisible
27        End If
28    Next
29Else
30    MsgBox ("密码错误")
31    ActiveWorkbook.Close Savechanges:=True '不保存关闭工作簿
32End If
33End Sub

工作表函数 ¶

介绍 ¶

vbscript

'Countif  Vlookup这些函数在VBA里调用：Application.WorksheetFunction
Instr() '函数可返回一个字符串在另一个字符串中首次出现的位置'
Split() '用于将特定字符分开'
On Error Resume Next '跳过错误语句'
IsNumeric()	'返回 Boolean 值，返回变量是否为一个数值'
Val()	'文本转化为数值'


Strings	文本函数
Math	数学函数
Datetime	日期时间
FileSystem	文件信息
Financial	财务函数
Information	信息函数
Interaction	交互函数

根据学号查询信息 ¶

 1Sub chaxun()
 2'On Error Resume Next  表示后面的程序出现"运行时错误"时，会继续运行，不中断
 3'VLookup（a,b,c,d） a：搜索的值  b：搜索的区域（多列） c：返回哪一列  d：是否精确匹配
 4
 5On Error Resume Next
 6Sheets(1).Range("d14:d22").ClearContents
 7d = Sheets(1).Range("d9")
 8For j = 2 To Sheets.Count
 9    Sheets(1).Range("d14") = WorksheetFunction.VLookup(d, Sheets(j).Range("a:h"), 5, 0)
10    Sheets(1).Range("d16") = WorksheetFunction.VLookup(d, Sheets(j).Range("a:h"), 6, 0)
11    Sheets(1).Range("d18") = WorksheetFunction.VLookup(d, Sheets(j).Range("a:h"), 3, 0)
12    Sheets(1).Range("d20") = WorksheetFunction.VLookup(d, Sheets(j).Range("a:h"), 8, 0)
13    Sheets(1).Range("d22") = Sheets(j).Name
14    If Sheets(1).Range("d14") <> "" Then
15        Exit For
16    End If
17Next
18End Sub
19
20Sub tongji()
21'WorksheetFunction 通过该对象可以使用工作表函数
22'CountA(a) a为某一区域，计算非空单元格
23'CountIf(a,b) a为某一区域，b为条件，统计满足条件的单元格
24For i = 2 To Sheets.Count
25    k = k + WorksheetFunction.CountA(Sheets(i).Range("a:a")) - 1
26    m = m + WorksheetFunction.CountIf(Sheets(i).Range("f:f"), "男")
27    w = w + WorksheetFunction.CountIf(Sheets(i).Range("f:f"), "女")
28Next
29Sheets(1).Range("d26") = k
30Sheets(1).Range("d27") = m
31Sheets(1).Range("d28") = w
32End Sub

拆分多表通用型 ¶

vbscript

Sub chaifenshuju()

Dim sht As Worksheet
Dim k, i, j As Integer
Dim irow As Integer '这个说的是一共多少行
Dim l As Integer
Dim str As String '这里是第1处修改，加入一个变量，用于提取当前工作表的名字
str = ActiveSheet.Name '这里是第2处修改，取得当前要处理的表的名字
l = InputBox("请输入你要按哪列分")
'删除无意义的表
Application.DisplayAlerts = False
If Sheets.Count > 1 Then
    For Each sht1 In Sheets
        If sht1.Name <> str Then '这里是第3处修改，不在用“数据”这个固定的名字了，而是用之前取到的名字
            sht1.Delete
        End If
    Next
End If
Application.DisplayAlerts = True '这个地方上课的时候我没改成true，请大家注意一下
irow = Sheets(str).Range("a65536").End(xlUp).Row '这里是第4处修改，不在用“sheet1”这个固定的表名字了，而是用之前取到的名字的表
'拆分表
For i = 2 To irow
    k = 0
    For Each sht In Sheets
        If sht.Name = Sheets(str).Cells(i, l) Then '这里是第5处修改，跟第四个修改一样，把原来的sheet1替换成sheets(str)
            k = 1
        End If
    Next
    If k = 0 Then
        Sheets.Add after:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = Sheets(str).Cells(i, l)   '这里是第6处修改，跟第四个修改一样，把原来的sheet1替换成sheets(str)
    End If
Next
'拷贝数据   注意：第7处修改。原有的Range("a1:f" & irow)已经改为Range("a1:z" & irow)  因为数据可能会列数很多，所以写成到z列，故意多写一些。￥￥￥￥￥￥￥￥￥￥￥￥￥
For j = 2 To Sheets.Count
    Sheets(str).Range("a1:z" & irow).AutoFilter Field:=l, Criteria1:=Sheets(j).Name  '这里是第8处修改，跟第四个修改一样，把原来的sheet1替换成sheets(str)
    Sheets(str).Range("a1:z" & irow).Copy Sheets(j).Range("a1")  '这里是第9处修改，跟第四个修改一样，把原来的sheet1替换成sheets(str)￥￥￥￥￥￥￥￥￥￥￥
Next
Sheets(str).Range("a1:z" & irow).AutoFilter   '这里是第10处修改，跟第四个修改一样，把原来的sheet1替换成sheets(str)
Sheets(str).Select   '这里是第11处修改，跟第四个修改一样，把原来的sheet1替换成sheets(str)
MsgBox "已处理完毕，牛逼不"
End Sub

多文件数据合并 ¶

Dir ¶

Dir(文件路径)：存在文件返回文件名，不存在返回空值
dir后面的参数可以支持通配符，例如：Dir(“d:/data/苏州.xls*”)

查询某文件下所有文件名 ¶

vbscript

'遍历文件，并提取文件名，以下代码会将data下所有文件名写入A列'
Sub test()
    Dim name As String, i
    i = 1
    name = Dir("G:\code\vba\VBA10\data\*.*")
    Do
        Sheets("data").Range("a" & i) = name
        name = Dir  '当dir() 查询结果有多个文件时，dir则依次返回一个文件名，然后为空，再然后出错
        i = i + 1
    Loop While name <> ""
End Sub

文件合并 ¶

vbscript

Sub 合并多文件数据()
Application.ScreenUpdating = False
    Dim name As String, i, wb As Workbook, sht As Worksheet
    i = 1
    name = Dir("G:\code\vba\跟着王佩丰学VBA附件\VBA10\data2\*.*")
    Do
        Set wb = Workbooks.Open("G:\code\vba\跟着王佩丰学VBA附件\VBA10\data2\" & name)
        For Each sht In wb.Sheets
            sht.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) '需指定哪个工作簿
            'split 拆分字符串，返回一个数组
            ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).name = Split(wb.name, ".")(0) & sht.name
        Next
        name = Dir
        wb.Close
    Loop While name <> ""
Application.ScreenUpdating = True
End Sub

find用法（规避错误） ¶

vbscript

Sub chazhao()
	Dim rng As Range
    '如果找不到以下代码并不会报错，而是rng为空'
	Set rng = Range("d:d").Find(Range("l3"))
    '进行以下判断，这样就可以避免错误'
	If Not rng Is Nothing Then
         Range("m3") = rng.Offset(0, 3)
	End If

End Sub

拆分工作表通用 ¶

vbscript

Sub chaifenshuju()
Dim sht As Worksheet
Dim k, i, j As Integer
Dim irow As Integer '这个说的是一共多少行
Dim l As Integer
Dim sht0 As Worksheet
Set sht0 = ActiveSheet '需要拆分的表'
l = InputBox("请输入你要按哪列分")

'删除无意义的表
Application.DisplayAlerts = False
If Sheets.Count > 1 Then
    For Each sht1 In Sheets
        If sht1.Name <> sht0.Name Then
            sht1.Delete
        End If
    Next
End If
Application.DisplayAlerts = True 

irow = sht0.Range("a65536").End(xlUp).Row
'拆分表
For i = 2 To irow
    k = 0
    For Each sht In Sheets
        If sht.Name = sht0.Cells(i, l) Then
            k = 1
        End If
    Next

    If k = 0 Then
        Sheets.Add after:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = sht0.Cells(i, l)
    End If

Next

'拷贝数据
For j = 2 To Sheets.Count
    sht0.Range("a1:z" & irow).AutoFilter Field:=l, Criteria1:=Sheets(j).Name
    sht0.Range("a1:z" & irow).Copy Sheets(j).Range("a1")
Next

sht0.Range("a1:z" & irow).AutoFilter
sht0.Select
MsgBox "已处理完毕，牛逼不"

End Sub

数组的妙用 ¶

统计金额 ¶

vbscript

Sub 总金额1()

Dim i, xrow, j, k, str, ti

ti = Timer

xrow = Range("a1000000").End(xlUp).Row
ReDim arr(1 To 3, 1 To xrow)
str = Range("O5").Value
For i = 2 To xrow
    If Range("H" & i) = str Then
        k = k + Range("J" & i)
        j = j + Range("L" & i)
    End If
Next

Range("P5") = k
Range("Q5") = k

MsgBox (Format(Timer - ti, "0.000000"))
End Sub
------------------------------------------------------------------------
Sub 总金额2()

Dim i, xrow, j, k, str, ti, arr()

ti = Timer	'获取时间'

xrow = Range("a1000000").End(xlUp).Row	
ReDim arr(1 To 3, 1 To xrow)	'重新定义数组大小'
str = Range("O5").Value
arr = Range("H1:J" & xrow).Value	'连续的将单元格区域赋值给数组，注意：带sheets.range(区域)，后面必须跟上value'
For i = 2 To xrow
    If arr(i, 1) = str Then
        k = k + arr(i, 3)
        j = j + arr(i, 2)
    End If
Next

Range("P5") = k

MsgBox (Format(Timer - ti, "0.000000"))	'当前获取时间-程序开始时间，结果为程序运行时间'
End Sub

查找销冠 ¶

vbscript

Sub test()
Dim arr()
Dim j, i As Integer

j = Range("a65536").End(xlUp).Row - 1

ReDim arr(1 To j)	'重新定义数组大小'

For i = 1 To j
    arr(i) = Range("b" & i + 1) * Range("c" & i + 1)
Next

Range("h3") = Application.WorksheetFunction.Max(arr)	'调用工作表函数，数组可以看成一个单元格区域'
'match，查看元素在区域内出现的位置'
Range("h2") = Range("a" & Application.WorksheetFunction.Match(Range("h3"), arr, 0) + 1)

MsgBox LBound(arr) '数组下限'

End Sub

计算回款信息 ¶

vbscript

'问题：有许多汇款账单，但不知道谁是谁，现在知道收到的回款总额(124704)以及订单数(4)，求是哪些账单（每个账单金额唯一）'
'思路：尝试组合所有可能的组合，将金额加起来为124704的订单找出来'
Sub huikuan()
Dim arr(), i, j, k, xrow, t
t = Timer
xrow = Range("a65535").End(xlUp).Row - 1
arr = Range("A2:A" & xrow + 1)
For i = 1 To xrow
    For j = 1 To xrow
        For k = 1 To xrow
            For l = 1 To xrow
                If arr(i, 1) + arr(j, 1) + arr(k, 1) + arr(l, 1) = Range("k3") Then '四笔订单和为收到汇款总额时
                    Range("F3") = arr(i, 1)
                    Range("G3") = arr(j, 1)
                    Range("H3") = arr(k, 1)
                    Range("I3") = arr(k, 1)
                    GoTo 100    '程序跳到100处，这里结束所有循环
                End If
            Next
        Next
    Next
Next
100
Range("L3") = Timer - t '程序执行时间
End Sub

ADO ¶

 1Sub adoTest()
 2Dim conn As New ADODB.Connection
 3Dim sql As String, arr()
 4
 5conn.Open "Provider = Microsoft.ACE.OLEDB.12.0;Data Source=G:\data\Edata.xlsx;extended properties=""excel 12.0;HDR=YES""" '打开excle文件，指定扩展属性以及表头
 6
 7'conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=D:\data\Adata.accdb" '打开access数据库，只需要指定提供者和数据源
 8
 9'conn.Open "Provider=SQLOLEDB;DataSource=" & Path & ";Initial Catolog=" & strDataName 'Mysql数据库
10
11'conn.Open "Provider=MSDASQL;Driver={SQL Server};Server=" & Path & ";Database=" & strDataName 'MSSQL数据库
12
13'conn.Open "Provider=madaora;Data Source=MyOracleDB; User Id=UserID; Password=Password" 'Oracle数据库
14
15sql = "select * from [data$]" '从data工作表查询所有数据
16sql = "select * from [data$] where 性别=男" '条件查询
17sql = "select * from [data$] union all select * from [data2$]" '合并两个表数据
18
19Range("a2").CopyFromRecordset conn.Execute(sql) '将查询的记录写入A2单元格
20
21arr = Application.WorksheetFunction.Transpose(conn.Execute(sql).GetRows)    '将查询的记录赋值到数组
22
23'关闭链接
24conn.Close
25End Sub