VBA完整学习笔记1-39集（共60集）
第26集：VBA数组-7：VBA排序算法之插入排序和希尔排序
第1集：宏与VBA
1 什么是VBA，它有什么作用
A 实现Excel中没有提供的功能
B 提高运行速度
C 编写自定义函数
D 实现自动化功能
F 通过插入窗体做小型管理软件
2 VBA在哪里存放的？怎么运行的
3、什么是宏？宏和VBA有什么关系？
4、录制一个宏
5、编写第一个宏
第2集：VBA中的语句、对象、方法与属性
一、VBA属性
VBA属性就是VBA对象所具有的特点
表示某个对象的属性的方法是
对象.属性=属性值
Sub ttt()
Range("a1").Value = 100
End Sub
Sub ttt1()
Sheets(1).Name = "工作表改名了"
End Sub
Sub ttt2()
Sheets("Sheet2").Range("a1").Value = "abcd"
End Sub
Sub ttt3()
Range("A2").Interior.ColorIndex = 3
End Sub
二 、VBA方法
VBA方法是作用于VBA对象上的动作
表示用某个方法作用于VBA的对象上，可以用下面的格式：
Sub ttt4()
牛排.做 熟的程度:=七成熟
Range("A1").Copy Range("A2")
End Sub
Sub ttt5()
Sheet1.Move before:=Sheets("Sheet3")
End Sub
三、VBA对象
VBA中的对象其实就是我们操作的具有方法、属性的excel中支持的对象
Excel中的几个常用对象表示方法
1、工作簿
Workbooks 代表工作簿集合，所有的工作簿,Workbooks(N)，表示已打开的第N个工作簿
Workbooks ("工作簿名称")
ActiveWorkbook 正在操作的工作簿
ThisWorkBook 代码所在的工作簿
2、工作表
Sheets("工作表名称")
Sheet1 表示第一个插入的工作表,Sheet2表示第二个插入的工作表....
Sheets(n) 表示按排列顺序，第n个工作表
ActiveSheet 表示活动工作表，光标所在工作表
worksheet 也表示工作表，但不包括图表工作表、宏工作表等。
3、单元格
cells 所有单元格
Range ("单元格地址")
Cells(行数,列数)
Activecell 正在选中或编辑的单元格
Selection 正被选中或选取的单元格或单元格区域
VBA中的代码的基本结构与组成部分
四VBA语句
1、宏程序语句
运行后可以完成一个功能
Sub test() 开始语句
Range("a1") = 100
End Sub 结束语句
2、函数程序语句
运行后可以返回一个值
Function shcount()
shcount = Sheets.Count
End Function
3、在程序中应用的语句
Sub test2()
Call test
End Sub
Sub test3()
For x = 1 To 100 for next 循环语句
Cells(x, 1) = x
Next x
End Sub
第3集：循环语句
if判断语句
Sub 判断1() '单条件判断
If Range("a1").Value > 0 Then
Range("b1") = "正数"
Else
Range("b1") = "负数或0"
End If
End Sub
Sub 判断2() '多条件判断
If Range("a1").Value > 0 Then
Range("b1") = "正数"
ElseIf Range("a1") = 0 Then
Range("b1") = "等于0"
ElseIf Range("B1") <= 0 Then
Range("b1") = "负数"
End If
End Sub
Sub 多条件判断2()
If Range("a1") <> "" And Range("a2") <> "" Then
Range("a3") = Range("a1") * Range("a2")
End If
End Sub
select判断
Sub 判断1() '单条件判断
Select Case Range("a1").Value
Case Is > 0
Range("b1") = "正数"
Case Else
Range("b1") = "负数或0"
End Select
End Sub
Sub 判断2() '多条件判断
Select Case Range("a1").Value
Case Is > 0
Range("b1") = "正数"
Case Is = 0
Range("b1") = "0"
Case Else
Range("b1") = "负数"
End Select
End Sub
Sub 判断3()
If Range("a3") < "G" Then
MsgBox "A-G"
End If
End Sub
判断范围
Sub if区间判断()
If Range("a2") <= 1000 Then
Range("b2") = 0.01
ElseIf Range("a2") <= 3000 Then
Range("b2") = 0.03
ElseIf Range("a2") > 3000 Then
Range("b2") = 0.05
End If
End Sub
Sub select区间判断()
Select Case Range("a2").Value
Case 0 To 1000
Range("b2") = 0.01
Case 1001 To 3000
Range("b2") = 0.03
Case Is > 3000
Range("b2") = 0.05
End Select
End Sub
第4集：判断语句
Sub s1()
Dim rg As Range
For Each rg In Range("a1:b7,d5:e9")
If rg = "" Then
rg = 0
End If
Next rg
End Sub
Sub s2()
Dim x As Integer
Do
x = x + 1
If Cells(x + 1, 1) <> Cells(x, 1) + 1 Then
Cells(x, 2) = "断点"
Exit Do
End If
Loop Until x = 14
End Sub
Sub t1()
Range("d2") = Range("b2") * Range("c2")
Range("d3") = Range("b3") * Range("c3")
Range("d4") = Range("b4") * Range("c4")
Range("d5") = Range("b5") * Range("c5")
Range("d6") = Range("b6") * Range("c6")
End Sub
Sub t2()
Dim x As Integer
For x = 10000 To 2 Step -3
Range("d" & x) = Range("b" & x) * Range("c" & x)
Next x
End Sub
Sub t3()
Dim rg As Range
For Each rg In Range("d2:d18")
rg = rg.Offset(0, -1) * rg.Offset(0, -2)
Next rg
End Sub
Sub t4()
Dim x As Integer
x = 1
Do
x = x + 1
Cells(x, 4) = Cells(x, 2) * Cells(x, 3)
Loop Until x = 18
End Sub
Sub t5()
x = 1
Do While x < 18
x = x + 1
Cells(x, 4) = Cells(x, 2) * Cells(x, 3)
Loop
End Sub
第5集：VBA变量
Dim m As Integer
'变量
'一、什么是变量？
'所谓变量，就是可变的量。就好象在内存中临时存放的一个小盒子，这个小盒子放的什么物体不固定。
Sub t1()
Dim X As Integer 'x就是一个变量
For X = 1 To 10
Cells(X, 1) = X
Next X
End Sub
'二、小盒子里可以放什么？
'1 放数字
'如t1
'2 放文本
Sub t2()
Dim st As String
Dim X As Integer
For X = 1 To 10
st = st & "Excel精英培训"
Next X
End Sub
'3 放对象
Sub t3()
Dim rg As Range
Set rg = Range("a1")
rg = 100
End Sub
'4 放数组
Sub t4()
Dim arr(1 To 10) As Integer, X As Integer
For X = 1 To 10
arr(X) = X
Next X
End Sub
'三、变量的类型和声明
'1 变量的类型
'详见帮助文件
'2 为什么要声明变量
'3 声明变量
'dim public
'四、变量的存活周期
'1 过程级变量:过程结束，变量值释放
'如t1
'2 模块级变量:变量的值只在本模块中保持，工作簿关闭时随时释放
'例5
Sub t6()
m = 1
End Sub
Sub t5()
MsgBox m
m = 7
End Sub
'3 全局级变量: 在所有的模块中都可以调用，值会保存到EXCEL关闭时才会被释放。
' public 变量
Sub t7()
MsgBox qq
End Sub
'五 变量的释放
'一般情况下，过程级变量在过程运行结束后就会自动从内存中释放，而只有一些从外部借用的对象变量才需要使用set 变量=nothing进行释放。
第6集：函数与公式
Option Explicit
'一、在单元格中输入公式
'1、用VBA在单元格中输入普通公式
Sub t1()
Range("d2") = "=b2*c2"
End Sub
Sub t2()
Dim x As Integer
For x = 2 To 6
Cells(x, 4) = "=b" & x & "*c" & x
Next x
End Sub
'2、用VBA在单元格输入带引号的公式
Sub t3()
Range("c16") = "=SUMIF(A2:A6,""b"",B2:B6)" '遇到单引号就把单引号加倍
End Sub
'3、用VBA在单元格中输入数组公式
Sub t4()
Range("c9").FormulaArray = "=SUM(B2:B6*C2:C6)"
End Sub
'二、利用单元格公式返回值
Sub t5()
Range("d16") = Evaluate("=SUMIF(A2:A6,""b"",B2:B6)")
Range("d9") = Evaluate("=SUM(B2:B6*C2:C6)")
End Sub
'三、借用工作表函数
Sub t6()
Range("d8") = Application.WorksheeFunction.CountIf(Range("A1:A10"), "B")
End Sub
'四、利用VBA函数
Sub t7()
Range("C20") = VBA.InStr(Range("a20"), "E")
End Sub
'五、编写自定义函数
Function wn()
wn = Application.Caller.Parent.Name
End Function
第8集：VBA分支与End语句
Option Explicit
'一、END语句
'作用：强制退出所有正在运行的程序。
'二、Exit语句
'退出指定的语句
'1、Exit Sub
Sub e1()
Dim x As Integer
For x = 1 To 100
Cells(1, 1) = x
If x = 5 Then
Exit Sub
End If
Next x
Range("b1") = 100
End Sub
'2、Exit function
Function ff()
Dim x As Integer
For x = 1 To 100
If x = 5 Then
Exit Function
End If
Next x
ff = 100
End Function
'3、Exit for
Sub e2()
Dim x As Integer
For x = 1 To 100
Cells(1, 1) = x
If x = 5 Then
Exit For
End If
Next x
Range("b1") = 100
End Sub
'4、Exit do
Sub e3()
Dim x As Integer
Do
x = x + 1
Cells(1, 1) = x
If x = 5 Then
Exit Do
End If
Loop Until x = 100
Range("b1") = 100
End Sub
Option Explicit
'Goto语句,跳转到指定的地方
Sub t1()
Dim x As Integer
Dim sr
100:
sr = Application.InputBox("请输入数字", "输入提示")
If Len(sr) = 0 Or Len(sr) = 5 Then GoTo 100
End Sub
'gosub..return ,跳过去,再跳回来
Sub t2()
Dim x As Integer
For x = 1 To 10
If Cells(x, 1) Mod 2 = 0 Then GoSub 100
Next x
Exit Sub
100:
Cells(x, 1) = "偶数"
Return '跳到gosub 100 这一句
End Sub
分支语句
'on error resume next '遇到错误,跳过继续执行下一句
Sub t3()
On Error Resume Next
Dim x As Integer
For x = 1 To 10
Cells(x, 3) = Cells(x, 2) * Cells(x, 1)
Next x
End Sub
'on error goto '出错时跳到指定的行数
Sub t4()
On Error GoTo 100
Dim x As Integer
For x = 1 To 10
Cells(x, 3) = Cells(x, 2) * Cells(x, 1)
Next x
Exit Sub
100:
MsgBox "在第" & x & "行出错了"
End Sub
'on error goto 0 '取消错误跳转
Sub t5()
On Error Resume Next
Dim x As Integer
For x = 1 To 10
If x > 5 Then On Error GoTo 0
Cells(x, 3) = Cells(x, 2) * Cells(x, 1)
Next x
Exit Sub
End Sub
第7集：VBE编辑器
'VBA第七集：VBE编辑器
'一、VBE的窗口
'1、工程窗口
'A 显示工作簿工作表对象
'B 窗体
'C 模块
'D 类模块
'range("a1")=10
'对应工程窗口的对象和模板，显示其所具体的一些特征。
'3、代码窗口
'A 注释文字的设置
'B 代码缩进的设置
'C 代码强制转行的设置
'D 代码运行和调试
'逐句运行
'设置断点
'E 对象列表框和过程列表框
'4、立即窗口
'立即窗口可以把运行过程中的值立即显示出来，主要用于程序的调试
Sub d()
Dim x As Integer, st As String
For x = 1 To 10
st = st & Cells(x, 1)
Debug.Print "第" & x & "次运行结果:" & st
Next x
End Sub
'5、本地窗口
'在本地窗口中可以显示运行中断时对象信息、变量值、数组信息等。
Sub d1()
Dim x As Integer, k As Integer
For x = 1 To 10
k = k + Cells(x, 1)
Next x
End Sub
第9集：excel文件操作
excel文件的操作
'1 判断A.Xls文件是否存在
Sub W1()
If Len(Dir("d:/A.xls")) = 0 Then
MsgBox "A文件不存在"
Else
MsgBox "A文件存在"
End If
End Sub
'2 判断A.Xls文件是否打开
Sub W2()
Dim X As Integer
For X = 1 To Windows.Count
If Windows(X).Caption = "A.XLS" Then
MsgBox "A文件打开了"
Exit Sub
End If
Next
End Sub
'3 excel文件新建和保存
Sub W3()
Dim wb As Workbook
Set wb = Workbooks.Add
wb.Sheets("sheet1").Range("a1") = "abcd"
wb.SaveAs "D:/B.xls"
End Sub
'4 excel文件打开和关闭
Sub w4()
Dim wb As Workbook
Set wb = Workbooks.Open("D:/B.xls")
MsgBox wb.Sheets("sheet1").Range("a1").Value
wb.Close False
End Sub
'5 excel文件保存和备份
Sub w5()
Dim wb As Workbook
Set wb = ThisWorkbook
wb.Save
wb.SaveCopyAs "D:/ABC.xls"
End Sub
'6 excel文件复制和删除
Sub W6()
FileCopy "D:/ABC.XLS", "E:/ABCd.XLS"
Kill "D:/ABC.XLS"
End Sub
excel文件的几个概念
'excel文件和工作簿
'excel文件就是excel工作簿，excel文件打开需要excel程的支持
'Workbooks 工作簿集合，泛指excel文件或工作簿
'Workbooks("A.xls")，名称为A的excel工作簿
Sub t1()
Workbooks("A.xls").Sheets(1).Range("a1") = 100
End Sub
'workbooks(2)，按打开顺序，第二个打开的工作簿。
Sub t2()
Workbooks(2).Sheets(2).Range("a1") = 200
End Sub
'ActiveWorkbook ，当打开多个excel工作簿时，你正在操作的那个就是ActiveWorkbook（活动工作簿）
'Thisworkbook，VBA程序所在的工作簿，无论你打开多少个工作簿，无论当前是哪个工作簿是活动的,thisworkbook就是指它所在的工作簿。
'工作簿窗口
'Windows("A.xls"),A工作簿的窗口，使用windows可以设置工作簿窗口的状态，如是否隐藏等。
Sub t3()
Windows("A.xls").Visible = False
End Sub
Sub t4()
Windows(2).Visible = True
End Sub
第10集：excel工作表操作
工作表文件的操作
'1 判断A工作表文件是否存在
Sub s1()
Dim X As Integer
For X = 1 To Sheets.Count
If Sheets(X).Name = "A" Then
MsgBox "A工作表存在"
Exit Sub
End If
Next
MsgBox "A工作表不存在"
End Sub
'2 excel工作表的插入
Sub s2()
Dim sh As Worksheet
Set sh = Sheets.Add
sh.Name = "模板"
sh.Range("a1") = 100
End Sub
'3 excel工作表隐藏和取消隐藏
Sub s3()
Sheets(2).Visible = True
End Sub
'4 excel工作表的移动
Sub s4()
Sheets("Sheet2").Move before:=Sheets("sheet1") 'sheet2移动到sheet1前面
Sheets("Sheet1").Move after:=Sheets(Sheets.Count) 'sheet1移动到所有工作表的最后面
End Sub
'6 excel工作表的复制
Sub s5() '在本工作簿中
Dim sh As Worksheet
Sheets("模板").Copy before:=Sheets(1)
Set sh = ActiveSheet
sh.Name = "1日"
sh.Range("a1") = "测试"
End Sub
Sub s6() '另存为新工作簿
Dim wb As Workbook
Sheets("模板").Copy
Set wb = ActiveWorkbook
wb.SaveAs ThisWorkbook.Path & "/1日.xls"
wb.Sheets(1).Range("b1") = "测试"
wb.Close True
End Sub
'7 保护工作表
Sub s7()
Sheets("sheet2").Protect "123"
End Sub
Sub s8() '判断工作表是否添加了保护密码
If Sheets("sheet2").ProtectContents = True Then
MsgBox "工作簿保护了"
Else
MsgBox "工作簿没有添加保护"
End If
End Sub
'8 工作表删除
Sub s9()
Application.DisplayAlerts = False
Sheets("模板").Delete
Application.DisplayAlerts = True
End Sub
'9 工作表的选取
Sub s10()
Sheets("sheet2").Select
End Sub
excel工作表的分类
'excel工作表有两大类，一类是我们平常用的工作表(worksheet)，另一类是图表、宏表等。这两类的统称是sheets
'sheets 工作表集合，泛指excel各种工作表
'Sheets("A")，名称为A的excel工作表
Sub t1()
Sheets("A").Range("a1") = 100
End Sub
'workbooks(2)，按打开顺序，第二个打开的工作簿。
Sub t2()
Sheets(2).Range("a1") = 200
End Sub
'ActiveSheet ，当打开多个excel工作簿时，你正在操作的那个就是ActiveSheet
第11集：单元格选取
'1 表示一个单元格(a1)
Sub s()
Range("a1").Select
Cells(1, 1).Select
Range("A" & 1).Select
Cells(1, "A").Select
Cells(1).Select
[a1].Select
End Sub
'2 表示相邻单元格区域
Sub d() '选取单元格a1:c5
' Range("a1:c5").Select
' Range("A1", "C5").Select
' Range(Cells(1, 1), Cells(5, 3)).Select
'Range("a1:a10").Offset(0, 1).Select
Range("a1").Resize(5, 3).Select
End Sub
'3 表示不相邻的单元格区域
Sub d1()
Range("a1,c1:f4,a7").Select
'Union(Range("a1"), Range("c1:f4"), Range("a7")).Select
End Sub
Sub dd() 'union示例
Dim rg As Range, x As Integer
For x = 2 To 10 Step 2
If x = 2 Then Set rg = Cells(x, 1)
Set rg = Union(rg, Cells(x, 1))
Next x
rg.Select
End Sub
'4 表示行
Sub h()
'Rows(1).Select
'Rows("3:7").Select
'Range("1:2,4:5").Select
Range("c4:f5").EntireRow.Select
End Sub
'5 表示列
Sub L()
' Columns(1).Select
' Columns("A:B").Select
' Range("A:B,D:E").Select
Range("c4:f5").EntireColumn.Select '选取c4:f5所在的行
End Sub
'6 重置坐标下的单元格表示方法
Sub cc()
Range("b2").Range("a1") = 100
End Sub
'7 表示正在选取的单元格区域
Sub d2()
Selection.Value = 100
End Sub
第12集：特殊单元格定位
'1 已使用的单元格区域
Sub d1()
Sheets("sheet2").UsedRange.Select
'wb.Sheets(1).Range("a1:a10").Copy Range("i1")
End Sub
'2 某单元格所在的单元格区域
Sub d2()
Range("b8").CurrentRegion.Select
End Sub
'3 两个单元格区域共同的区域
Sub d3()
Intersect(Columns("b:c"), Rows("3:5")).Select
End Sub
'4 调用定位条件选取特殊单元格
Sub d4()
Range("A1:A6").SpecialCells(xlCellTypeBlanks).Select
End Sub
'5 端点单元格
Sub d5()
Range("a65536").End(xlUp).Offset(1, 0) = 1000
End Sub
Sub d6()
Range(Range("b6"), Range("b6").End(xlToRight)).Select
End Sub
实例
Option Explicit
Sub t()
Dim x As Integer
For x = 2 To 6
If Cells(x, 2) > 0 Then
Cells(x, "N") = "1月"
Else
Cells(x, "N") = Range("b" & x).End(xlToRight).Column - 1 & "月"
End If
Next x
End Sub
第13集：单元格信息
Option Explicit
'1 单元格的值
Sub x1()
Range("b10") = Range("c2").Value
Range("b11") = Range("c2").Text
Range("c10") = "'" & Range("I3").Formula
End Sub
'2 单元格的地址
Sub x2()
With Range("b2").CurrentRegion
[b12] = .Address
[c12] = .Address(0, 0)
[d12] = .Address(1, 0)
[e12] = .Address(0, 1)
[f12] = .Address(1, 1)
End With
End Sub
'3 单元格的行列信息
Sub x3()
With Range("b2").CurrentRegion
[b13] = .Row
[b14] = .Rows.Count
[b15] = .Column
[b16] = .Columns.Count
[b17] = .Range("a1").Address
End With
End Sub
'4、单元格的格式信息
Sub x4()
With Range("b2")
[b19] = .Font.Size
[b20] = .Font.ColorIndex
[b21] = .Interior.ColorIndex
[b22] = .Borders.LineStyle
End With
End Sub
'5、单元格批注信息
Sub x5()
[B24] = Range("I2").Comment.Text
End Sub
'6 单元格的位置信息
Sub x6()
With Range("b3")
[b26] = .Top
[b27] = .Left
[b28] = .Height
[b29] = .Width
End With
End Sub
'7 单元格的上级信息
Sub x7()
With Range("b3")
[b31] = .Parent.Name
[b32] = .Parent.Parent.Name
End With
End Sub
'8 内容判断
Sub x8()
With Range("i3")
[b34] = .HasFormula
[b35] = .Hyperlinks.Count
End With
End Sub
'9 单元格数据类型（另讲）
第14集：单元格的格式
单元格的数字格式
'一、判断数值的格式
'1 判断是否为空单元格
Sub d1()
[b1] = ""
'If Range("a1") = "" Then
'If Len([a1]) = 0 Then
If VBA.IsEmpty([a1]) Then
[b1] = "空值"
End If
End Sub
'2 判断是否为数字
Sub d2()
[b2] = ""
'If VBA.IsNumeric([a2]) And [a2] <> "" Then
'If Application.WorksheetFunction.IsNumber([a2]) Then
[b2] = "数字"
End If
End Sub
'3 判断是否为文本
Sub d3()
[b3] = ""
'If Application.WorksheetFunction.IsText([A3]) Then
If VBA.TypeName([a3].Value) = "String" Then
[b3] = "文本"
End If
End Sub
'4 判断是否为汉字
Sub d4()
[b4] = ""
If [a4] > "z" Then
[b4] = "汉字"
End If
End Sub
'5 判断错误值
Sub d10()
[b5] = ""
'If VBA.IsError([a5]) Then
If Application.WorksheetFunction.IsError([a5]) Then
[b5] = "错误值"
End If
End Sub
Sub d11()
[b6] = ""
If VBA.IsDate([a6]) Then
[b6] = "日期"
End If
End Sub
'二、设置单元格自定义格式
Sub d30()
Range("d1:d8").NumberFormatLocal = "0.00"
End Sub
'三、按指定格式从单元格返回数值
'Format函数语法(和工作表数Text用法基本一致)
'Format(数值,自定义格式代码)
单元格的颜色
Option Explicit
'Excel中的颜色
'Excel中的颜色可以用两种方式获取，一种是EXCEL内置颜色，另一种是利用QBCOLOR函数返回
Sub y1()
Dim x As Integer
Range("a1:b60").Clear
For x = 1 To 56
Range("a" & x) = x
Range("b" & x).Font.ColorIndex = 3
Next x
End Sub
Sub y2()
Dim x As Integer
For x = 0 To 15
Range("d" & x + 1) = x
Range("e" & x + 1).Interior.Color = QBColor(x)
Next x
End Sub
Sub y3()
Dim 红 As Integer, 绿 As Integer, 蓝 As Integer
红 = 255
绿 = 123
蓝 = 100
Range("g1").Interior.Color = RGB(红, 绿, 蓝)
End Sub
单元格合并
Sub h1()
Range("g1:h3").Merge
End Sub
'合并区域的返回信息
Sub h2()
Range("e1") = Range("b3").MergeArea.Address '返回单元格所在的合并单元格区域
End Sub
'判断是否含合并单元格
Sub h3()
'MsgBox Range("b2").MergeCells
' MsgBox Range("A1:D7").MergeCells
Range("e2") = IsNull(Range("a1:d7").MergeCells)
Range("e3") = IsNull(Range("a9:d72").MergeCells)
End Sub
'综合示例
'合并H列相同单元格
Sub h4()
Dim x As Integer
Dim rg As Range
Set rg = Range("h1")
Application.DisplayAlerts = False
For x = 1 To 13
If Range("h" & x + 1) = Range("h" & x) Then
Set rg = Union(rg, Range("h" & x + 1))
Else
rg.Merge
Set rg = Range("h" & x + 1)
End If
Next x
Application.DisplayAlerts = True
End Sub
第15集：单元格编辑示例
单元格行列的删除和插入
Option Explicit
Sub c1()
Rows(4).Insert
End Sub
Sub c2() '插入行并复制公式
Rows(4).Insert
Range("3:4").FillDown
Range("4:4").SpecialCells(xlCellTypeConstants) = ""
End Sub
Sub c3()
Dim x As Integer
For x = 2 To 20
If Cells(x, 3) <> Cells(x + 1, 3) Then
Rows(x + 1).Insert
x = x + 1
End If
Next x
End Sub
Sub c4()
Dim x As Integer, m1 As Integer, m2 As Integer
Dim k As Integer
m1 = 2
For x = 2 To 1000
If Cells(x, 1) = "" Then Exit Sub
If Cells(x, 3) <> Cells(x + 1, 3) Then
m2 = x
Rows(x + 1).Insert
Cells(x + 1, "c") = Cells(x, "c") & " 小计"
Cells(x + 1, "h") = "=sum(h" & m1 & ":h" & m2 & ")"
Cells(x + 1, "h").Resize(1, 4).FillRight
Cells(x + 1, "i") = ""
x = x + 1
m1 = m2 + 2
End If
Next x
End Sub
Sub c44()
'个人方法
Dim x As Integer
Dim t As Integer
t = Range("c65536").End(xlUp).Row
For x = t To 2 Step -1
If Cells(x, 3) <> Cells(x - 1, 3) Then
Rows(x).Insert
Cells(Cells(x, "C").Offset(1, 0).End(xlDown).Row + 1, "C") = Cells(Cells(x, "C").Offset(1, 0).End(xlDown).Row, "C") & " 小计"
Cells(Cells(x, "H").Offset(1, 0).End(xlDown).Row + 1, "H") = _
Application.Sum(Range(Cells(x, "h").Offset(1, 0), Cells(x, "H").Offset(1, 0).End(xlDown)))
End If
Next x
End Sub
Sub dd() '删除小计行
Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
单元格输入
Option Explicit
'1 单元格输入
Sub t1()
Range("a1") = "a" & "b"
Range("b1") = "a" & Chr(10) & "b" '换行答输入
End Sub
'2 单元格复制和剪切
Sub t2()
Range("a1:a10").Copy Range("c1") 'A1：A10的内容复制到C1
End Sub
Sub t3()
Range("a1:a10").Copy
ActiveSheet.Paste Range("d1") '粘贴至D1
End Sub
Sub t4()
Range("a1:a10").Copy
Range("e1").PasteSpecial (xlPasteValues) '只粘贴为数值
End Sub
Sub t5()
Range("a1:a10").Cut
ActiveSheet.Paste Range("f1") '粘贴到f1
End Sub
Sub t6()
Range("c1:c10").Copy
Range("a1:a10").PasteSpecial Operation:=xlAdd '选择粘贴-加
End Sub
Sub T7()
Range("G1:G10") = Range("A1:A10").Value
End Sub
'3 填充公式
Sub T8()
Range("b1") = "=a1*10"
Range("b1:b10").FillDown '向下填充公式
End Sub
第16集：单元格查找
单元格查询
Option Explicit
'1 使用循环查找 (在单元格中查找效率太低)
'2 调用工作表函数
Sub c1() '判断是否存在,并查找所在行数
Dim hao As Integer
Dim icount As Integer
icount = Application.WorksheetFunction.CountIf(Sheets("库存明细表").[b:b], [g3])
If icount > 0 Then
MsgBox "该入库单号码已经存在，请不要重复录入"
MsgBox Application.WorksheetFunction.Match([g3], Sheets("库存明细表").[b:b], 0)
End If
End Sub
'3 使用Find方法
Sub c2()
Dim r As Integer, r1 As Integer
Dim icount As Integer
icount = Application.WorksheetFunction.CountIf(Sheets("库存明细表").[b:b], [g3])
If icount > 0 Then
r = Sheets("库存明细表").[b:b].Find(Range("G3"), Lookat:=xlWhole).Row '查找号码第一次出现的位置
r1 = Sheets("库存明细表").[b:b].Find([g3], , , , , xlPrevious).Row
MsgBox r & ":" & r1
End If
End Sub
Sub c3() '返回最下一行非空行的行数
MsgBox Sheets("库存明细表").Cells.Find("*", , , , , xlPrevious).Row
End Sub
入库单实例
Option Explicit
Sub 输入()
Dim c As Integer '号码在库存表中的个数
Dim r As Integer '入库单的数据行数
Dim cr As Integer '库存明细表中第一个空行的行数
With Sheets("库存明细表")
c = Application.CountIf(.[b:b], Range("g3"))
If c > 0 Then
MsgBox "该单据号码已经存在！,请不要重复录入"
Exit Sub
Else
r = Application.CountIf(Range("b6:b10"), "<>")
cr = .[b65536].End(xlUp).Row + 1
.Cells(cr, 1).Resize(r, 1) = Range("e3")
.Cells(cr, 2).Resize(r, 1) = Range("g3")
.Cells(cr, 3).Resize(r, 1) = Range("c3")
.Cells(cr, 4).Resize(r, 6) = Cells(6, 2).Resize(r, 6).Value
MsgBox "输入已完成"
End If
End With
End Sub
Sub 查找()
Dim c As Integer '号码在库存表中的个数
Dim r As Integer '入库单的数据行数
With Sheets("库存明细表")
c = Application.CountIf(.[b:b], Range("g3"))
If c = 0 Then
MsgBox "该单据号码不存在！"
Exit Sub
Else
r = .[b:b].Find(Range("g3"), , , , , xlNext).Row
Range("c3") = .Cells(r, 3)
Range("e3") = .Cells(r, 1)
Cells(6, 2).Resize(c, 5) = .Cells(r, 4).Resize(c, 5).Value
MsgBox "查询已完成"
End If
End With
End Sub
Sub 删除()
Dim c As Integer '号码在库存表中的个数
Dim r As Integer '入库单的数据行数
With Sheets("库存明细表")
c = Application.CountIf(.[b:b], Range("g3"))
If c = 0 Then
MsgBox "该单据号码不存在！"
Exit Sub
Else
r = .[b:b].Find(Range("g3"), , , , , xlNext).Row
.Range(r & ":" & c + r - 1).Delete
MsgBox "删除已完成"
End If
End With
End Sub
Sub 修改()
Call 删除
Call 输入
End Sub
第17集：excel事件程序(上)
Option Explicit
Private Sub Worksheet_Calculate()
MsgBox "公式的值发生了改变"
End Sub
Private Sub Worksheet_Deactivate()
MsgBox "谢谢使用sheet3"
End Sub
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
MsgBox Target.Address
End Sub
Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable)
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
End Sub
Private Sub Worksheet_Activate()
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
End Sub
Private Sub Worksheet_PivotTableBeforeCommitChanges(ByVal TargetPivotTable As PivotTable, ByVal ValueChangeStart As Long, ByVal ValueChangeEnd As Long, Cancel As Boolean)
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
End Sub
第18集：工作簿事件
Private Sub Workbook_Deactivate()
End Sub
Private Sub Workbook_Open()
UserForm1.Show
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
'Cancel = True
End Sub
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If Sh.name = "Sheet2" Then
MsgBox Target.Address
MsgBox Sh.name
End If
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
End Sub
Private Sub Workbook_NewSheet(ByVal Sh As Object)
MsgBox "本工作簿禁止插入新工作表"
Application.DisplayAlerts = False
Sh.Delete
Application.DisplayAlerts = True
End Sub
Private Sub Workbook_BeforePrint(Cancel As Boolean)
MsgBox "此excel文件禁止打印，如需打印请与管理员联系"
Cancel = True
End Sub
Private Sub Workbook_Activate()
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
MsgBox "你点击保存按钮了"
End Sub
第19集：excel程序事件
Public WithEvents app As Excel.Application
Private Sub app_NewWorkbook(ByVal Wb As Workbook)
End Sub
Private Sub app_SheetActivate(ByVal Sh As Object)
End Sub
Private Sub app_WorkbookOpen(ByVal Wb As Workbook)
' a = Application.InputBox("请输入打开excel程序口令", "安全提示")
' If a <> 123 Then
' Wb.Close False
' End If
End Sub
Private Sub Workbook_Open()
Set app = Excel.Application
End Sub
Option Explicit
Public WithEvents app As Excel.Application
Private Sub app_NewWorkbook(ByVal Wb As Workbook)
Wb.Close False
MsgBox "你没有新建工作簿的权限"
End Sub
Private Sub app_WorkbookBeforePrint(ByVal Wb As Workbook, Cancel As Boolean)
MsgBox "你没有打印本工作簿的权限！"
Cancel = True
End Sub
Private Sub app_WorkbookBeforeSave(ByVal Wb As Workbook, ByVal SaveAsUI As Boolean, Cancel As Boolean)
MsgBox "本工作簿不能保存修改！谢谢合作"
Cancel = True
End Sub
Private Sub app_WorkbookNewSheet(ByVal Wb As Workbook, ByVal Sh As Object)
Application.DisplayAlerts = False
Sh.Delete
Application.DisplayAlerts = True
End Sub
Private Sub app_WorkbookOpen(ByVal Wb As Workbook)
Dim a
If Wb.Name = "open.xla" Then Exit Sub
a = Application.InputBox("请输入打开excel程序口令", "安全提示")
If a <> 123 Then
Wb.Close False
MsgBox "很抱歉！你没有打开本机excel程序权限。"
End If
End Sub
Private Sub Workbook_Open()
Set app = Excel.Application
End Sub
第20集：VBA数组-1：数组基础
第1_了解VBA运算特点
'****************************************************************************************************
'* VBA数组教程 *
'* --------excel精英培训网:兰色幻想 *
'****************************************************************************************************
Sub v4() '运行时间0.01秒
Dim t
t = Timer
For x = 1 To 100000
m = m + 1000 '真接调用内存中的值
Next x
MsgBox Timer - t
End Sub
Sub v5() '运行时间0.5秒
Dim t
t = Timer
For x = 1 To 100000
m = m + Cells(1, 1) '调用单元格中的值
Next x
MsgBox Timer - t
End Sub
第2_什么是VBA数组
'1、什么是VBA数组呢？
'VBA数组就是储存一组数据的数据空间?数据类型可以数字,可以是文本,可以是对象,也可以是VBA数组.
'2 VBA数组存在形态
' VBA数组是以变量形式存放的一个空间,它也有行有列，也可以是三维空间。
'1) 常量数组
'array(1,2)
'array(array(1,2,4),array("a","b","c"))
'2) 静态数组
'x(4) '有5个位置，编号从0~4
'arr(1 to 10) '有10个位置，编号1~10
'arr(1 to 10,1 to 2) '10行2列的空间，总共20个位置，这是二维数组
'arr(1 to 10,1 to 2,1 to 3) '三维数组，总10*2*3=60个位置。这是三维数组
'3)动态数组
'arr() '不知道有多少行多少列
第3_VBA数组的写入
Option Explicit
'向VBA数组中写入数据
'1、按编号(标)写入和读取
Sub t1() '写入一维数组
Dim x As Integer
Dim arr(1 To 10)
arr(2) = 190
arr(10) = 5
End Sub
Sub t2() '向二维数组写入数据和读取
Dim x As Integer, y As Integer
Dim arr(1 To 5, 1 To 4)
For x = 1 To 5
For y = 1 To 4
arr(x, y) = Cells(x, y)
Next y
Next x
MsgBox arr(3, 1)
End Sub
'2、动态数组
Sub t3()
Dim arr()
Dim row
row = Sheets("sheet2").Range("a65536").End(xlUp).row - 1
ReDim arr(1 To row)
For x = 1 To row
arr(x) = Cells(x, 1)
Next x
Stop
End Sub
'3、批量写入
Sub t4() '由常量数组导入
Dim arr
arr = Array(1, 2, 3, "a")
Stop
End Sub
Sub t5() '由单元格区域导入
Dim arr
arr = Range("a1:d5")
Stop
End Sub
第21集：BA数组-2读取
第1_了解VBA运算特点
'****************************************************************************************************
'* VBA数组教程 *
'* --------excel精英培训网:兰色幻想 *
'****************************************************************************************************
Sub v4() '运行时间0.01秒
Dim t
t = Timer
For x = 1 To 100000
m = m + 1000 '真接调用内存中的值
Next x
MsgBox Timer - t
End Sub
Sub v5() '运行时间0.5秒
Dim t
t = Timer
For x = 1 To 100000
m = m + Cells(1, 1) '调用单元格中的值
Next x
MsgBox Timer - t
End Sub
第2_什么是VBA数组
'1、什么是VBA数组呢？
'VBA数组就是储存一组数据的数据空间?数据类型可以数字,可以是文本,可以是对象,也可以是VBA数组.
'2 VBA数组存在形态
' VBA数组是以变量形式存放的一个空间,它也有行有列，也可以是三维空间。
'1) 常量数组
'array(1,2)
'array(array(1,2,4),array("a","b","c"))
'2) 静态数组
'x(4) '有5个位置，编号从0~4
'arr(1 to 10) '有10个位置，编号1~10
'arr(1 to 10,1 to 2) '10行2列的空间，总共20个位置，这是二维数组
'arr(1 to 10,1 to 2,1 to 3) '三维数组，总10*2*3=60个位置。这是三维数组
'3)动态数组
'arr() '不知道有多少行多少列
第3_VBA数组的写入
Option Explicit
'向VBA数组中写入数据
'1、按编号(标)写入和读取
Sub t1() '写入一维数组
Dim x As Integer
Dim arr(1 To 10)
arr(2) = 190
arr(10) = 5
End Sub
Sub t2() '向二维数组写入数据和读取
Dim x As Integer, y As Integer
Dim arr(1 To 5, 1 To 4)
For x = 1 To 5
For y = 1 To 4
arr(x, y) = Cells(x, y)
Next y
Next x
MsgBox arr(3, 1)
End Sub
'2、动态数组
Sub t3()
Dim arr()
Dim row
row = Sheets("sheet2").Range("a65536").End(xlUp).row - 1
ReDim arr(1 To row)
For x = 1 To row
arr(x) = Cells(x, 1)
Next x
Stop
End Sub
'3、批量写入
Sub t4() '由常量数组导入
Dim arr
arr = Array(1, 2, 3, "a")
Stop
End Sub
Sub t5() '由单元格区域导入
Dim arr
arr = Range("a1:d5")
Stop
End Sub
第4_VBA数组的读取
Option Explicit
'VBA数组
'1、在内存中读取
'在内存中读取后用于继续运算，直接用下面的格式
'数组变量(5)
'数组变量(3,2)
'例:
Sub d1()
Dim arr, arr1()
Dim x As Integer, k As Integer, m As Integer
arr = Range("a1:a10") '把单元格区域导入内存数组中
m = Application.CountIf(Range("a1:a10"), ">10") '计算大于10的个数
ReDim arr1(1 To m)
For x = 1 To 10
If arr(x, 1) > 10 Then
k = k + 1
arr1(k) = arr(x, 1)
MsgBox arr1(k)
End If
Next x
Stop
End Sub
'2、读取存入单元格中
Sub d2() '二维数组存入单元格
Dim arr, arr1(1 To 5, 1 To 1)
Dim x As Integer
arr = Range("b2:c6")
For x = 1 To 5
arr1(x, 1) = arr(x, 1) * arr(x, 2)
Next x
Range("d2").Resize(10) = arr1
End Sub
Sub vl()
Dim arr, arr1
Dim x, k As Integer
Dim tt As Long
Application.ScreenUpdating = False
arr = Range("I2:J1433")
arr1 = Range("f2:g1433")
For x = 1 To 1432
For k = 1 To 1432
If arr(k, 1) = arr1(x, 1) Then
arr1(x, 2) = arr(k, 2)
Exit For
End If
Range("g2").Resize(1432) = arr1(x, 2)
Next k
Next x
Application.ScreenUpdating = True
End Sub
Sub d3() '一维数组存入单元格
Dim arr, arr1(1 To 5)
Dim x As Integer
arr = Range("b2:c6")
For x = 1 To 5
arr1(x) = arr(x, 1) * arr(x, 2)
Next x
'Range("a13").Resize(1, 5) = arr1
Range("d2").Resize(5) = Application.Transpose(arr1)
End Sub
Sub d4() '数组部分存入
Dim arr, arr1(1 To 10000, 1 To 1)
Dim x As Integer
arr = Range("b2:c6")
For x = 1 To 5
arr1(x, 1) = arr(x, 1) * arr(x, 2)
Next x
Range("d2").Resize(5) = arr1
End Sub
第22集：数组-3
第5_数组的空间
Option Explicit
'1、数组的大小
'数组是用编号排序的，那么如何获得一个数组的大小呢
'Lbound(数组) 可以获取数组的最小下标(编号)
'Ubound(数组) 可以获取数组的最大上标(编号)
'Ubound(数组,1) 可以获得数组的行方面(第1维)最大上标
'Ubound(数组,2) 可以获得数组的列方向(第2维)的最大上标
Sub d6()
Dim arr
Dim k, m
arr = Range("a2:d5")
For x = 1 To UBound(arr, 1)
Next x
End Sub
'2、动态数组的动态扩充
'如果一个数组无法或不方便计算出总的大小，而在一些特殊情况下又不允许有空位。这时我们就需要用动态的导入方法
'
'ReDim Preserve arr() 可以声明一个动态大小的数组，而且可以保留原来的数值，就相当于厂房小了，可以改扩建增大，但是它只能
'让最未维实现动态，如果是一维不存在最未维，只有一维
例子1见sheet1工作表
Sub d7()
Dim arr, arr1()
arr = Range("a1:d6")
Dim x, k
For x = 1 To UBound(arr)
If arr(x, 1) = "B" Then
k = k + 1
ReDim Preserve arr1(1 To 4, 1 To k)
arr1(1, k) = arr(x, 1)
arr1(2, k) = arr(x, 2)
arr1(3, k) = arr(x, 3)
arr1(4, k) = arr(x, 4)
End If
Next x
Range("a8").Resize(k, 4) = Application.Transpose(arr1)
End Sub
Sub d8()
Dim arr, arr1(1 To 100000, 1 To 4)
arr = Range("a1:d6")
Dim x, k
For x = 1 To UBound(arr)
If arr(x, 1) = "B" Then
k = k + 1
arr1(k, 1) = arr(x, 1)
arr1(k, 2) = arr(x, 2)
arr1(k, 3) = arr(x, 3)
arr1(k, 4) = arr(x, 4)
End If
Next x
Range("a15").Resize(k, 4) = arr1
End Sub
'3 清空数组
'清空数组使用earse语句
Sub d9()
Dim arr, arr1(1 To 1000, 1 To 1)
Dim x, m, k
arr = Range("a1:a16")
For x = 1 To UBound(arr)
If arr(x, 1) <> "" Then
k = k + 1
arr1(k, 1) = arr(x, 1)
Else
m = m + 1
Range("c1").Offset(0, m).Resize(k) = arr1
Erase arr1
k = 0
End If
Next x
End Sub
第23集：数组-4：数组与函数
可以生成数组的函数
Option Explicit
' 1、split函数
'按分隔符把字符串截取成VBA数组,该数组是一维数组，编号从0开始
'split(字符串,分隔符)
Sub t1()
Dim sr, arr
sr = "A-BC-FGR-H"
arr = VBA.Split(sr, "-")
MsgBox Join(arr, ",")
End Sub
' 2、Filter函数：
'按条件筛选符合条件的值组成一个新的数组
'Filter(数组,筛选条件,是/否)
'注：如果是（true）则返回包含的数组，如果否则返回非包含的数组
Sub t2()
Dim arr, arr1, arr2
arr = Application.Transpose(Range("A2:A10"))
arr1 = VBA.Filter(arr, "W", True)
arr2 = VBA.Filter(arr, "W", False)
Range("B2").Resize(UBound(arr1) + 1) = Application.Transpose(arr1)
Range("C2").Resize(UBound(arr2) + 1) = Application.Transpose(arr2)
End Sub
'3、index函数：
'调用该工作表函数可以把二维数组的某一列或某一行截取出来，构成一个新的数组。
' Application.Index(二维数组,0,列数)) 返回二维数组
' Application.Index(二维数组,行数,0)) 返回一维数组
Sub t3()
Dim arr, arr1, arr2
arr = Range("a2:d6")
arr1 = Application.Index(arr, , 1)
arr2 = Application.Index(arr, 4, 0)
Stop
End Sub
'4、vlookup函数
'Vlookup函数的第一个参数可以用VBA数组，返回的也是一个VBA数组
Sub t4()
Dim arr, arr1
arr = Range("a2:d6")
arr1 = Application.VLookup(Array("B", "C"), arr, 4, 0)
End Sub
'5 Sumif函数和Countif函数
'Countif和sumif函数的第二个参数都可以使用数组，所以也可以返回一个VBA数组，如：
Sub t5()
Dim T
T = Timer
Dim arr
arr = Application.SumIf(Range("a2:a10000"), Array("B", "C", "G", "R"), Range("B2:B10000"))
MsgBox Timer - T
Stop
End Sub
Sub t55()
Dim T
T = Timer
Dim arr, arr1(1 To 4, 1 To 2), x
arr1(1, 1) = "B"
arr1(2, 1) = "C"
arr1(3, 1) = "G"
arr1(4, 1) = "R"
' arr = Range("a1:d10000")
For x = 2 To 10000
Select Case Cells(x, 1)
Case "B"
arr1(1, 2) = arr1(1, 2) + Cells(x, 2)
Case "C"
arr1(2, 2) = arr1(2, 2) + Cells(x, 2)
Case "G"
arr1(3, 2) = arr1(3, 2) + Cells(x, 2)
Case "R"
arr1(4, 2) = arr1(4, 2) + Cells(x, 2)
End Select
Next x
MsgBox Timer - T
End Sub
数组的处理
Option Explicit
'1 数组的最值
Sub s()
Dim arr1()
arr1 = Array(1, 12, 4, 5, 19)
MsgBox "1, 12, 4, 5, 19最大值" & Application.Max(arr1)
MsgBox "1, 12, 4, 5, 19最小值:" & Application.Min(arr1)
MsgBox "1, 12, 4, 5, 19第二大值：" & Application.Large(arr1, 2)
MsgBox "1, 12, 4, 5, 19第二小值：" & Application.Small(arr1, 2)
End Sub
'2、求和
'用application.Sum (数组)
'3 统计个数
'counta和count函数可以统计VBA数组的数字个数及所有已填充内容的个数
Sub s1()
Dim arr1, arr2(0 To 10), x
arr1 = Array("a", "3", "", 4, 6)
For x = 0 To 4
arr2(x) = arr1(x)
Next x
MsgBox "数组1的数字个数：" & Application.Count(arr2)
MsgBox "数组2的已填充数值的个数" & Application.CountA(arr2)
End Sub
'3 在数组里查找
Sub s2()
Dim arr
On Error Resume Next
arr = Array("a", "c", "b", "f", "d")
MsgBox Application.Match("f", arr, 0)
If Err.Number = 13 Then
MsgBox "查找不到"
End If
End Sub
第24集：VBA数组-5：数组与单元格格式
Option Explicit
'数组也可以设置格式？
'数组除了数字类型外，当然没有颜色、字体等格式，但是别忘了range对象可以表示多个连续或不连续的单元格区域
'利用上述特点，我们就是要数组构造单元格地址串，然后批量对单元格进行格式设置。
'注意，单元格地址串不能>255，所以如果单元格操作过多，我们还需要分次分批设置单元格格式
Sub 填充颜色()
Range("a2:d2,a7:d7,a10:d10").Interior.ColorIndex = 3
End Sub
Option Explicit
Sub 单元格循环()
Dim x As Integer
Dim t
清除颜色
t = Timer
For x = 2 To Range("a65536").End(xlUp).Row
If Range("d" & x) > 500 Then
Range(Cells(x, 1), Cells(x, 4)).Interior.ColorIndex = 3
End If
Next x
MsgBox Timer - t
End Sub
Sub 清除颜色()
Range("a:d").Interior.ColorIndex = xlNone
End Sub
Sub 数组方法()
Dim arr, t
Dim x As Integer
Dim sr As String, sr1 As String
清除颜色
t = Timer
arr = Range("d2:d" & Range("a65536").End(xlUp).Row)
For x = 1 To UBound(arr)
If x = UBound(arr) And sr <> "" Then Range(Left(sr, Len(sr) - 1)).Interior.ColorIndex = 3
If arr(x, 1) > 500 Then
sr1 = sr
sr = sr & "A" & x + 1 & ":D" & x + 1 & ","
If Len(sr) > 255 Then
sr = sr1
Range(Left(sr, Len(sr) - 1)).Interior.ColorIndex = 3
sr = ""
End If
End If
Next x
MsgBox Timer - t
End Sub
Sub 数组方法2()
Dim arr, t
Dim x As Integer, x1 As Integer
Dim sr As String, sr1 As String
清除颜色
t = Timer
arr = Range("d2:d" & Range("a65536").End(xlUp).Row)
For x = 1 To UBound(arr)
If x = UBound(arr) Then Range(Left(sr, Len(sr) - 1)).Interior.ColorIndex = 3
If arr(x, 1) > 500 Then
sr1 = sr
x1 = x + 1
Do
x = x + 1
Loop Until arr(x, 1) <= 500
sr = sr & "A" & x1 & ":D" & x & ","
If Len(sr) > 255 Then
sr = sr1
x = x1 - 1
Range(Left(sr, Len(sr) - 1)).Interior.ColorIndex = 3
sr = ""
End If
x = x - 1
End If
Next x
MsgBox Timer - t
End Sub
Sub 数组方法3()
Dim arr, t
Dim x As Integer, x1 As Integer
Dim sr As String, sr1 As String
清除颜色
t = Timer
arr = Range("d2:d" & Range("a65536").End(xlUp).Row)
For x = 1 To UBound(arr)
If x = UBound(arr) Then Application.Intersect(Range("a:d"), Range(Left(sr, Len(sr) - 1))).Interior.ColorIndex = 3
If arr(x, 1) > 500 Then
sr1 = sr
x1 = x + 1
Do
x = x + 1
Loop Until arr(x, 1) <= 500
sr = sr & x1 & ":" & x & ","
If Len(sr) > 255 Then
sr = sr1
x = x1 - 1
Application.Intersect(Range("a:d"), Range(Left(sr, Len(sr) - 1))).Interior.ColorIndex = 3
sr = ""
End If
x = x - 1
End If
Next x
MsgBox Timer - t
End Sub
第25集：VBA数组之VBA排序算法(上)
插入排序
Sub 插入排序()
Dim arr, temp, x, y, t, iMax, k, k1, k2
t = Timer
arr = Range("a1:a10")
For x = 1 + 1 To UBound(arr)
temp = arr(x, 1) '记得要插入的值
For y = x - 1 To 1 Step -1
If arr(y, 1) <= temp Then Exit For
arr(y + 1, 1) = arr(y, 1)
'k1 = k1 + 1
Next y
arr(y + 1, 1) = temp
'k2 = k2 + 1
Next
' Range("d3").Resize(UBound(arr)) = ""
' Range("d3").Resize(UBound(arr)) = arr
'Range("d2") = Timer - t
MsgBox k1
End Sub
Sub 插入排序单元格演示()
On Error Resume Next
Dim arr, temp, x, y, t, iMax, k
For x = 2 To 10
temp = Cells(x, 1) '记得要插入的值
Range("A" & x).Interior.ColorIndex = 3
For y = x - 1 To 1 Step -1
Range("A" & y).Interior.ColorIndex = 4
If Cells(y, 1) <= temp Then Exit For
Cells(y + 1, 1) = Cells(y, 1)
Range("A" & y).Interior.ColorIndex = xlNone
Next y
Cells(y + 1, 1) = temp
Range("A" & y).Interior.ColorIndex = xlNone
Range("A" & x).Interior.ColorIndex = xlNone
Next
End Sub
快速排序
Sub dd()
Dim arr1(0 To 4999) As Long, arr, x, t
t = Timer
arr = Range("a1:a5000")
For x = 1 To 5000
arr1(x - 1) = arr(x, 1)
Next x
QuickSort arr1()
Range("f2") = Timer - t
End Sub
Public Sub QuickSort(ByRef lngArray() As Long)
Dim iLBound As Long
Dim iUBound As Long
Dim iTemp As Long
Dim iOuter As Long
Dim iMax As Long
iLBound = LBound(lngArray)
iUBound = UBound(lngArray)
'若只有一个值，不排序
If (iUBound - iLBound) Then
For iOuter = iLBound To iUBound
If lngArray(iOuter) > lngArray(iMax) Then iMax = iOuter
Next iOuter
iTemp = lngArray(iMax)
lngArray(iMax) = lngArray(iUBound)
lngArray(iUBound) = iTemp
'开始快速排序
InnerQuickSort lngArray, iLBound, iUBound
End If
Range("f3").Resize(5000) = Application.Transpose(lngArray)
End Sub
Private Sub InnerQuickSort(ByRef lngArray() As Long, ByVal iLeftEnd As Long, ByVal iRightEnd As Long)
Dim iLeftCur As Long
Dim iRightCur As Long
Dim iPivot As Long
Dim iTemp As Long
If iLeftEnd >= iRightEnd Then Exit Sub
iLeftCur = iLeftEnd
iRightCur = iRightEnd + 1
iPivot = lngArray(iLeftEnd)
Do
Do
iLeftCur = iLeftCur + 1
Loop While lngArray(iLeftCur) < iPivot
Do
iRightCur = iRightCur - 1
Loop While lngArray(iRightCur) > iPivot
If iLeftCur >= iRightCur Then Exit Do
'交换值
iTemp = lngArray(iLeftCur)
lngArray(iLeftCur) = lngArray(iRightCur)
lngArray(iRightCur) = iTemp
Loop
递归快速排序
lngArray(iLeftEnd) = lngArray(iRightCur)
lngArray(iRightCur) = iPivot
InnerQuickSort lngArray, iLeftEnd, iRightCur - 1
InnerQuickSort lngArray, iRightCur + 1, iRightEnd
End Sub
冒泡排序
Option Explicit
Sub 冒泡排序()
Dim arr, temp, x, y, t, k
t = Timer
arr = Range("a1:a10")
For x = 1 To UBound(arr) - 1
For y = x + 1 To UBound(arr) '只和当前数字下面的数进行比较
If arr(x, 1) > arr(y, 1) Then '如果它大于它下面某一个数字
temp = arr(x, 1)
arr(x, 1) = arr(y, 1)
arr(y, 1) = temp
End If
Next y
Next x
Range("b3").Resize(x) = ""
Range("b3").Resize(x) = arr
'Range("b2") = Timer - t
MsgBox k
End Sub
Sub 冒泡排序演示()
Dim arr, temp, x, y, t, k
For x = 1 To 9
Range("a" & x).Interior.ColorIndex = 3
For y = x + 1 To 10 '只和当前数字下面的数进行比较
Range("a" & y).Interior.ColorIndex = 4
If Cells(x, 1) > Cells(y, 1) Then '如果它大于它下面某一个数字
temp = Cells(x, 1)
Cells(x, 1) = Cells(y, 1)
Cells(y, 1) = temp
2 End If
Range("a" & y).Interior.ColorIndex = xlNone
Next y
Range("a" & x).Interior.ColorIndex = xlNone
Next x
End Sub
第26集：VBA数组-7：VBA排序算法之插入排序和希尔排序
希尔排序
Sub 希尔排序()
Dim arr
Dim 总大小, 间隔, x, y, temp, t
t = Timer
arr = Range("a1:a30")
总大小 = UBound(arr) - LBound(arr) + 1
间隔 = 1
If 总大小 > 13 Then
Do While 间隔 < 总大小
间隔 = 间隔 * 3 + 1
Loop
间隔 = 间隔 9
End If
' Stop
Do While 间隔
For x = LBound(arr) + 间隔 To UBound(arr)
temp = arr(x, 1)
For y = x - 间隔 To LBound(arr) Step -间隔
If arr(y, 1) <= temp Then Exit For
arr(y + 间隔, 1) = arr(y, 1)
' k1 = k1 + 1
Next y
arr(y + 间隔, 1) = temp
Next x
间隔 = 间隔 3
Loop
' MsgBox k1
'Range("e3").Resize(5000) = ""
Range("d1").Resize(UBound(arr)) = arr
'Range("e2") = Timer - t
End Sub
Sub 打乱顺序()
Dim arr, temp, x
arr = Range("a1:a" & Range("a65536").End(xlUp).Row)
For x = 1 To UBound(arr)
num = Int(Rnd() * UBound(arr) + 1)
temp = arr(num, 1)
arr(num, 1) = arr(x, 1)
arr(x, 1) = temp
Next x
Range("a1").Resize(x - 1) = arr
End Sub
Sub 希尔排序单元格演示()
Dim arr
Dim 总大小, 间隔, x, y, temp, t
t = Timer
arr = Range("a1:a" & Range("a65536").End(xlUp).Row)
总大小 = UBound(arr) - LBound(arr) + 1
间隔 = 1
If 总大小 > 13 Then
Do While 间隔 < 总大小
间隔 = 间隔 * 3 + 1
Loop
间隔 = 间隔 9
End If
' Stop
Do While 间隔
For x = LBound(arr) + 间隔 To UBound(arr)
temp = Cells(x, 1)
Range("a" & x).Interior.ColorIndex = 3
For y = x - 间隔 To LBound(arr) Step -间隔
Range("a" & y).Interior.ColorIndex = 6
If Cells(y, 1) <= temp Then Exit For
Cells(y + 间隔, 1) = Cells(y, 1)
' k1 = k1 + 1
Next y
Cells(y + 间隔, 1) = temp
Range("a1:a30").Interior.ColorIndex = xlNone
Next x
间隔 = 间隔 3
Loop
' MsgBox k1
'Range("e3").Resize(5000) = ""
' Range("d1").Resize(UBound(arr)) = arr
'Range("e2") = Timer - t
End Sub
选择排序
Option Explicit
Sub 选择排序()
Dim arr, temp, x, y, t, iMax, k, k1, k2
t = Timer
arr = Range("a1:a10")
For x = UBound(arr) To 1 + 1 Step -1
iMax = 1 '最大的索引
For y = 1 To x
If arr(y, 1) > arr(iMax, 1) Then iMax = y
Next y
temp = arr(iMax, 1)
arr(iMax, 1) = arr(x, 1)
arr(x, 1) = temp
Next x
'Range("c3").Resize(UBound(arr)) = ""
'Range("c3").Resize(UBound(arr)) = arr
'Range("c2") = Timer - t
'MsgBox k1
End Sub
Sub 选择排序单元格演示()
Dim arr, temp, x, y, t, iMax, k, k1, k2
For x = 10 To 2 Step -1
iMax = 1
Range("a" & x).Interior.ColorIndex = 3
For y = 1 To x
Range("a" & y).Interior.ColorIndex = 4
If Cells(y, 1) > Cells(iMax, 1) Then
Range("a" & iMax).Interior.ColorIndex = xlNone
iMax = y
End If
Range("a" & y).Interior.ColorIndex = xlNone
Range("a" & iMax).Interior.ColorIndex = 6
Next y
temp = Cells(iMax, 1)
Cells(iMax, 1) = Cells(x, 1)
Cells(x, 1) = temp
Range("a" & x).Interior.ColorIndex = xlNone
Range("a" & iMax).Interior.ColorIndex = xlNone
Next x
End Sub
第27集：VBA字典-1
基本概念
Option Explicit
'1 什么是VBA字典？
'字典（dictionary）是一个储存数据的小仓库。共有两列。
'第一列叫key , 不允许有重复的元素。
'第二列是item,每一个key对应一个item，本列允许为重复
'Key item
'A 10
'B 20
'C 30
'Z 10
'2 即然有数组，为什么还要学字典？
'原因:提速，具体表现在
'1) A列只能装入非重复的元素，利用这个特点可以很方便的提取不重复的值
'2) 每一个key对应一个唯一的item，只要指点key的值，就可以马上返回其对应的item，利用字典可以实现快速的查找
'3 字典有什么局限？
'字典只有两列，如果要处理多列的数据，还需要通过字符串的组合和拆分来实现。
'字典调用会耗费一定时间，如果是数据量不大，字典的优势就无法体现出来。
'4 字典在哪里？如何创建字典？
'字典是由scrrun.dll链接库提供的，要调用字典有两种方法
'第一种方法：直接创建法
'Set d = CreateObject("scripting.dictionary")
'第二种方法：引用法
'工具-引用-浏览-找到scrrun.dll-确定
字典的使用
Option Explicit
'1 装入数据
Sub t1()
Dim D As New Dictionary
Dim x As Integer
For x = 2 To 4
D.Add Cells(x, 1).Value, Cells(x, 2).Value
Next x
MsgBox D.Keys(0)
MsgBox D.Keys(1)
MsgBox D.Keys(2)
MsgBox D.Items(0)
'Stop
End Sub
'2 读取数据
Sub t2()
' Dim D
Dim D As New Dictionary
Dim arr
Dim x As Integer
' Set D = CreateObject("scripting.dictionary")
For x = 2 To 4
D.Add Cells(x, 1).Value, Cells(x, 2).Value
Next x
MsgBox D("李四")
MsgBox D.Keys(2)
Range("d1").Resize(D.Count) = Application.Transpose(D.Keys)
Range("e1").Resize(D.Count) = Application.Transpose(D.Items)
arr = D.Items
End Sub
'3 修改数据
Sub t3()
Dim D As New Dictionary
Dim x As Integer
For x = 2 To 4
D.Add Cells(x, 1).Value, Cells(x, 2).Value
Next x
D("李四") = 78
MsgBox D("李四")
D("赵六") = 100
MsgBox D("赵六")
End Sub
'4 删除数据
Sub t4()
Dim D As New Dictionary
Dim x As Integer
For x = 2 To 4
D(Cells(x, 1).Value) = Cells(x, 2).Value
Next x
D.Remove "李四"
' MsgBox d.Exists("李四")
D.RemoveAll
MsgBox D.Count
End Sub
'区分大小写
Sub t5()
Dim D As New Dictionary
Dim x
For x = 1 To 5
D(Cells(x, 1).Value) = ""
Next x
Stop
End Sub
ub 求和问题()
Dim arr, D As Object, ar
Dim i As Integer, j As Byte
Set D = CreateObject("scripting.dictionary")
arr = Sheet2.Range("a1").CurrentRegion '选定区域装入数组
Dim t$
For i = 1 To UBound(arr) '循环从数组第1行到数组的最后一行
t = arr(i, 1) & "|" & arr(i, 2)
If D.Exists(t) Then
D(t) = t & "|" & (--Split(D(t), "|")(2) + arr(i, 3)) '如果有相应的key,则提取对应item的的销售额与现有的相加，再组合后存入字典
Else
D(t) = t & "|" & arr(i, 3) '如果没有相应的Key，则存入"日期｜名称｜销售额"
End If
Next i
Erase arr
ReDim arr(1 To D.Count, 1 To 3)
ar = D.Items
For i = 1 To UBound(ar) + 1
For j = 1 To 3
arr(i, j) = Split(ar(i - 1), "|")(j - 1)
Next j
Next i
Sheet3.Range("a1").CurrentRegion.ClearContents
Sheet3.Range("a1").Resize(UBound(arr), 3) = arr
End Sub
第28集：VBA字典-2
字典与查找
Option Explicit
Sub 多表双向查找()
Dim d As New Dictionary
Dim x, y
Dim arr
For x = 3 To 5
arr = Sheets(x).Range("a2").Resize(Sheets(x).Range("a65536").End(xlUp).Row - 1, 2)
For y = 1 To UBound(arr)
d(arr(y, 1)) = arr(y, 2)
d(arr(y, 2)) = arr(y, 1)
Next y
Next x
MsgBox d("C1")
MsgBox d("吴情")
End Sub
字典与求和
Option Explicit
Sub 汇总()
Dim d As New Dictionary
Dim arr, x
arr = Range("a2:b10")
For x = 1 To UBound(arr)
d(arr(x, 1)) = d(arr(x, 1)) + arr(x, 2) 'key对应的item的值在原来的基础上加新的
Next x
Range("d2").Resize(d.Count) = Application.Transpose(d.Keys)
Range("e2").Resize(d.Count) = Application.Transpose(d.Items)
End Sub
字典与唯一值
Option Explicit
Sub 提取不重复的产品()
Dim d As New Dictionary
Dim arr, x
arr = Range("a2:a12")
For x = 1 To UBound(arr)
d(arr(x, 1)) = ""
Next x
Range("c2").Resize(d.Count) = Application.Transpose(d.Keys)
End Sub
第29集：VBA数组与字典综合应用之下棋法（兰色原创）
多列汇总
Option Explicit
Sub 下棋法之多列汇总()
Dim 棋盘(1 To 10000, 1 To 3)
Dim 行数
Dim arr, x, k
Dim d As New Dictionary
arr = Range("a2:c" & Range("a65536").End(xlUp).Row)
For x = 1 To UBound(arr)
If d.Exists(arr(x, 1)) Then
行数 = d(arr(x, 1))
棋盘(行数, 2) = 棋盘(行数, 2) + arr(x, 2)
棋盘(行数, 3) = 棋盘(行数, 3) + arr(x, 3)
Else
k = k + 1
d(arr(x, 1)) = k
棋盘(k, 1) = arr(x, 1)
棋盘(k, 2) = arr(x, 2)
棋盘(k, 3) = arr(x, 3)
End If
Next x
Range("f2").Resize(k, 3) = 棋盘
End Sub
多条件多列汇总
Option Explicit
Sub 下棋法之多条件多列汇总()
Dim 棋盘(1 To 10000, 1 To 4)
Dim 行数
Dim arr, x As Integer, sr As String, k As Integer
Dim d As New Dictionary
arr = Range("a2:d" & Range("a65536").End(xlUp).Row)
For x = 1 To UBound(arr)
sr = arr(x, 1) & "-" & arr(x, 2)
If d.Exists(sr) Then
行数 = d(sr)
棋盘(行数, 3) = 棋盘(行数, 3) + arr(x, 3)
棋盘(行数, 4) = 棋盘(行数, 4) + arr(x, 4)
Else
k = k + 1
d(sr) = k
棋盘(k, 1) = arr(x, 1)
棋盘(k, 2) = arr(x, 2)
棋盘(k, 3) = arr(x, 3)
棋盘(k, 4) = arr(x, 4)
End If
Next x
Range("g2").Resize(k, 4) = 棋盘
End Sub
数据透视式汇总
Option Explicit
Sub 下棋法之数据透视表式汇总()
Dim d As New Dictionary
Dim 棋盘(1 To 10000, 1 To 7)
Dim 行数, 列数
Dim arr, x, k
arr = Range("a2:c" & Range("a65536").End(xlUp).Row)
For x = 1 To UBound(arr)
列数 = (InStr("1月2月3月4月5月6月", arr(x, 2)) + 1) / 2 + 1
If d.Exists(arr(x, 1)) Then
行数 = d(arr(x, 1))
棋盘(行数, 列数) = 棋盘(行数, 列数) + arr(x, 3)
Else
k = k + 1
d(arr(x, 1)) = k
棋盘(k, 1) = arr(x, 1)
棋盘(k, 列数) = arr(x, 3)
End If
Next x
Range("f2").Resize(k, 7) = 棋盘
End Sub
第30集：自定义函数基础
什么是自定义函数
Option Explicit
'1 什么是自定义函数？
'在VBA中有VBA函数，我们还可以调用工作表函数，我们能不能自已编写函数呢？可以，这就是本集所讲的自定义函数
'2 怎么编写自定义函数？
'我们可以按下面的结构编写自定义函数
' Function 函数名称(参数1,参数2....)
'代码
'函数名称=返回的值或数组
' End Function
编写和使用自定义函数
Option Explicit
'1 取得工作表总个数的自定义函数
Function shcount()
shcount = Sheets.Count
End Function
Sub dd()
MsgBox getv(Range("a7"))
End Sub
'2 取得单元格显示值的自定义函数
Function getv(rg As Range)
getv = rg.Text
End Function
'3 截取字符串的函数
Function jiequ(sr As String, fh As String, wz As Integer)
Dim Arr
Arr = Split(sr, fh)
jiequ = Arr(wz - 1)
End Function
'4 提取不重复值的个数
Function 不重复个数(rg As Range)
Dim d, Arr, ar
Arr = rg
Set d = CreateObject("scripting.dictionary")
For Each ar In Arr
d(ar) = ""
Next ar
不重复个数 = d.Count
End Function
Sub test()
MsgBox jiequ("A-BRT-C-EF", "-", 2)
End Sub
自定义函数的常见问题
Option Explicit
'1 怎么让自定义函数在所有工作簿中使用？
'答： 把含有自定义函数的文件另存为加截宏，然后通过工具-加截宏-浏览找到这个文件-确定。
'2 怎么给自定义函数添加说明
'工具-宏-宏名输入自定义函数的名称-选项--在说明栏中写入这个函数的名称
'3、怎么给自定义函数分类
Sub 分类()
Application.MacroOptions "不重复个数", Category:=4
End Sub
'注:
'0 是全部
'1 财务
'2 日期和时间
'3 数学和三角
'4 统计
'5 查找和引用
'6 数据库
'7 文本
'8 逻辑
'9 信息
第31集：自定义函数的参数设置
参数不定的自定义函数
Option Explicit
Function cheng(ParamArray n())
Dim num, k
k = 0
For Each num In n
k = k + num
Next num
cheng = k
End Function
参数值默认和参数缺省
Option Explicit
Function shuiji1(maxnum, geshu, Optional qo As Integer)
Dim d As New Dictionary
Dim num
Application.Volatile
Do
num = Int(Rnd() * maxnum + 1)
If qo = 0 Then
d(num) = ""
ElseIf qo = 2 Then
If num Mod 2 = 0 Then d(num) = ""
ElseIf qo = 1 Then
If Not num Mod 2 = 0 Then d(num) = ""
End If
Loop Until d.Count = geshu
shuiji1 = Application.Transpose(d.Keys)
End Function
Function shuiji2(maxnum, geshu, Optional qo As Integer = 2)
Dim d As New Dictionary
Dim num, m
Application.Volatile
m = 1
Do
num = Int(Rnd() * maxnum + 1)
If qo = 2 Then
If num Mod 2 = 0 Then d(num) = ""
ElseIf qo = 1 Then
If Not num Mod 2 = 0 Then d(num) = ""
Else
Exit Function
End If
Loop Until d.Count = geshu
shuiji2 = Application.Transpose(d.Keys)
End Function
返回数组的自定义函数
Option Explicit
'返回一个固定区间固定个数的不重复随数
Function shuiji(maxnum, geshu) 'maxnum是区间最大的数,geshu是返回多少个不重复的数
Dim d As New Dictionary
Dim num
Application.Volatile
Do
num = Int(Rnd() * maxnum + 1)
d(num) = ""
Loop Until d.Count = geshu
shuiji = Application.Transpose(d.Keys)
End Function
第32集：Msgbox函数完全应用
Msgbox函数简介
Option Explicit
'一、什么MsgBox函数
'它可以弹出一个窗口，显示你设定的内容。并且窗口上有可以让你选择的按钮，点击不同的按钮会返回不同的数值。
'用msgbox信息窗口可以增加一个程序对话的机会，以告诉程序下一步应该怎么做
Sub test1()
MsgBox "大家好，我是msgbox窗口"
End Sub
'二、基本语法
'Msgbox (窗口中显示的内容,按钮和图示类别,窗口标题,相关的帮助文件,帮助文件上下文的编号)
窗口的按钮类型和图标
Option Explicit
'按钮类型
'消息窗体由按钮显示,图标显示,缺省按钮和其他特殊功能组合,这些功能都可以随意组合,组合他们只需要用"+"号
Sub test8()
MsgBox "test", vbYesNoCancel + vbExclamation + vbDefaultButton2 + vbMsgBoxHelpButton '显示确定和取消按钮并显示询问图标
End Sub
Sub test9()
MsgBox "mytest", vbExclamation + vbYesNo '显示危险图标和是否按钮
End Sub
Sub test10()
MsgBox "测试窗体结构", vbYesNoCancel + vbMsgBoxHelpButton + vbCritical + vbDefaultButton3, "测试四个按钮的窗口"
End Sub
Sub dd()
MsgBox "dd", vbYesNo + vbExclamation + vbMsgBoxHelpButton
End Sub
窗口和标题显示文字
Option Explicit
'1、窗口显示的内容
'1) 基本显示:只需要给第一个参数设置一个字符串或生成字符串的表达式即或
'例:
Sub test2()
MsgBox "你好,欢迎你的使用"
MsgBox "你好!,欢迎你使用" & ThisWorkbook.Name
End Sub
'2) 换行显示。
'chr(10) 可以生成换行符
'chr(13) 可以生成回车符
'vbcrlf 换行符和回车符
'vbCr 等同于chr(10)
'vblf 等同于chr(13)
'例：
Sub test3()
MsgBox "我爱" & Chr(10) & "Excel精英培训"
' MsgBox "我爱你" & Chr(13) & "Excel"
' MsgBox "今天" & vbCrLf & "我是水王"
End Sub
'3) 表格显示
'chr(9) 制表符
Sub test4()
MsgBox "姓名" & Chr(9) & "职业" & Chr(10) & "张三" & Chr(9) & "工程师" _
& Chr(10) & "于上伟" & Chr(9) & "教师"
End Sub
Sub test5()
Dim sr, x, y
For x = 1 To 5
For y = 1 To 3
sr = sr & Cells(x, y) & Chr(9) & Chr(9)
Next y
sr = sr & Chr(13)
Next x
MsgBox sr
End Sub
'用空格键设置
' space(n) 可以产生N个空格
Sub test6()
Dim x, y, sr, k
For x = 1 To 5
For y = 1 To 3
If VBA.IsNumeric(Cells(x, y)) Then
k = 12 - Len(Cells(x, y))
Else
k = 12 - Len(Cells(x, y)) * 2
End If
sr = sr & Cells(x, y) & Space(k)
Next y
sr = sr & Chr(13)
Next x
MsgBox sr
End Sub
'2 标题的显示文字
Sub test7()
MsgBox "核对关系出错了", , "系统提示"
End Sub
窗体的返回值
Option Explicit
'要想和消息框交流,还需要在我们点击窗体的按钮后能返回一个值,告诉程序我们点了哪个按钮.
Sub test11()
Dim k
k = MsgBox("测试返回值", vbYesNoCancel)
MsgBox "你点击了按钮:" & Choose(k, "确定", "取消", "终止", "重试", "忽略", "是", "否")
End Sub
'应用示例
Sub test12()
If MsgBox("你确定要删除第15行吗?", vbQuestion + vbYesNo, "删除提示") = vbYes Then
Rows(15).Delete
MsgBox "删除成功"
Else
MsgBox "你取消了删除"
End If
End Sub
设置信息框上的帮助
Option Explicit
'要添加帮助,需要设置msgbox 函数的第四和第五个参数
'第四个参数是帮助文件的路径,帮助文件要放在C:WINDOWSHelp路径下
'第五个参数和帮助文件本身有关,是为了准备的打开帮助文件而设置的上下文编号,如果没有则设置为0
Sub test13()
Dim x
x = MsgBox("测试添加帮助的效果", vbOKCancel + vbMsgBoxHelpButton, "测试帮助!", "D:/a.chm", 0) '"C:WINDOWSHelpexcel.chm", 0)
End Sub
自动定时关闭消息框
Option Explicit
'1 自动定时关闭消息框,可以用其他消息框完成
Sub AA()
Dim WshShell As Object
Set WshShell = CreateObject("Wscript.Shell")
WshShell.Popup "1秒后关闭！", 1, "提示！", 16
End Sub
特殊值及含义说明
常数 值 描述
vbOKOnly 0 只显示 确定 按钮
VbOKCancel 1 显示 确定 及 取消 按钮。
VbAbortRetryIgnore 2 显示 放弃、重试 及 忽略 按钮。
VbYesNoCancel 3 显示 是、否 及 取消 按钮。
VbYesNo 4 显示 是 及 否 按钮。
VbRetryCancel 5 显示 重试 及 取消 按钮。
VbCritical 16 危险图标
VbQuestion 32 询问图标
VbExclamation 48 警告图示
VbInformation 64 信息图标
vbDefaultButton1 0 第一个按钮是缺省值。
vbDefaultButton2 256 第二个按钮是缺省值。
vbDefaultButton3 512 第三个按钮是缺省值。
vbDefaultButton4 768 第四个按钮是缺省值。
vbApplicationModal 0 应用程序强制返回；应用程序一直被挂起，直到用户对消息框作出响应才继续工作。
vbSystemModal 4096 系统强制返回；全部应用程序都被挂起，直到用户对消息框作出响应才继续工作。
vbMsgBoxHelpButton 16384 将Help按钮添加到消息框
VbMsgBoxSetForeground 65536 指定消息框窗口作为前景窗口,就是显示在窗口的最上层
vbMsgBoxRight 524288 文本为右对齐
vbMsgBoxRtlReading 1048576 指定文本应为在希伯来和阿拉伯语系统中的从右到左显示
常数 值 说明
vbOK 1 确定
vbCancel2 取消
vbAbort 3 终止
vbRetry 4 重试
vbIgnore5 忽略
vbYes 6 是
vbNo 7 否
第33集：Inputbox函数方法应用
基本应用
Option Explicit
'最后一个参数数值说明:
' 值 含义
'0 公式
'1 数字
'2 文本 (字符串)
'4 逻辑值 (True 或 False)
'8 单元格引用，作为一个 Range 对象
'16 错误值，如 #N/A
'64 数值数组
' 1.引用单元格
'inputbox方法的最后个参数值为8的时候,可以用鼠标选择单元格的地址.使用变量是使用SET声明的对象变量,则返回的是一个单元格对象,
'否则反回的这个单元格区域的值,即VBA数组.
Sub text5()
Dim rg As Range
Set rg = Application.InputBox("请选择单元格区域", "选取提示", , , , , , 8)
MsgBox rg.Parent.Name & "!" & rg.Address
End Sub
Sub text6()
Dim rg
rg = Application.InputBox("请选择单元格区域", "选取提示", , , , , , 8)
MsgBox rg(2, 1)
End Sub
'2 公式引用
'当最后一个参数设置为0时,可以输入公式,返回的也是一个公式字符串,如果公式中含单元格引用,可以自动转换成rc引用格式(以当前活动单元格为参照)
Sub test7()
Dim r
r = Application.InputBox("请输入公式", "输入提示", , , , , , 0)
MsgBox r
End Sub
'3 限制输入返回的数值格式
Sub test8()
Dim r
r = Application.InputBox("请输入公式", "输入提示", , , , , , 1) '输入非数字则会提示无效的数字
MsgBox r
End Sub
Sub test9()
Dim r
r = Application.InputBox("请输入公式", "输入提示", , , , , , 2) '可以输入字符,当然,文字型数字也符字符
MsgBox TypeName(r)
End Sub
'4.数值数组
'可以选取单元格区域的值作为数组,也可以输入以带有大括号的一维或二维数组
Sub test10()
Dim r
r = Application.InputBox("请输入公式", "输入提示", , , , , , 64) '可以输入字符,当然,文字型数字也符字符
MsgBox r(2, 1)
End Sub
Inputbox语法概述
Option Explicit
'1.inpubox函数
'语法:
'inputbox(输入框显示内容,窗体标题,默认值,水平位置,垂直位置,帮助文件,帮助文件ID
'2.Application对象的Inputbox方法:显示一个接收用户输入的对话框。返回此对话框中输入的信息
'语法:
'Application.InputBox(对话框显示内容,输入框标题,文本框内默认值,x坐标,y坐标,帮助文件,帮助文件上下文ID,文本框内输入类型)
'最后一个参数数值说明:
' 值 含义
'0 公式
'1 数字
'2 文本 (字符串)
'4 逻辑值 (True 或 False)
'8 单元格引用，作为一个 Range 对象
'16 错误值，如 #N/A
'64 数值数组
'什么时候用方法,什么时候用函数
'从上面的参数可以看出inputbox函数和方法的不同之处是方法比函数多了后面几个参不数,如果只是简单的输入,可以用方法,
'如果需要添加帮助和设置输入类型,则用Application对象的Inputbox方法.
Inputbox的扩展应用
Option Explicit
'最后一个参数数值说明:
' 值 含义
'0 公式
'1 数字
'2 文本 (字符串)
'4 逻辑值 (True 或 False)
'8 单元格引用，作为一个 Range 对象
'16 错误值，如 #N/A
'64 数值数组
' 1.引用单元格
'inputbox方法的最后个参数值为8的时候,可以用鼠标选择单元格的地址.使用变量是使用SET声明的对象变量,则返回的是一个单元格对象,
'否则反回的这个单元格区域的值,即VBA数组.
Sub text5()
Dim rg As Range
Set rg = Application.InputBox("请选择单元格区域", "选取提示", , , , , , 8)
MsgBox rg.Parent.Name & "!" & rg.Address
End Sub
Sub text6()
Dim rg
rg = Application.InputBox("请选择单元格区域", "选取提示", , , , , , 8)
MsgBox rg(2, 1)
End Sub
'2 公式引用
'当最后一个参数设置为0时,可以输入公式,返回的也是一个公式字符串,如果公式中含单元格引用,可以自动转换成rc引用格式(以当前活动单元格为参照)
Sub test7()
Dim r
r = Application.InputBox("请输入公式", "输入提示", , , , , , 0)
MsgBox r
End Sub
'3 限制输入返回的数值格式
Sub test8()
Dim r
r = Application.InputBox("请输入公式", "输入提示", , , , , , 1) '输入非数字则会提示无效的数字
MsgBox r
End Sub
Sub test9()
Dim r
r = Application.InputBox("请输入公式", "输入提示", , , , , , 2) '可以输入字符,当然,文字型数字也符字符
MsgBox TypeName(r)
End Sub
'4.数值数组
'可以选取单元格区域的值作为数组,也可以输入以带有大括号的一维或二维数组
Sub test10()
Dim r
r = Application.InputBox("请输入公式", "输入提示", , , , , , 64) '可以输入字符,当然,文字型数字也符字符
MsgBox r(2, 1)
End Sub
第34集：调用Excel对话框
FileDialog对象
Option Explicit
'一 FileDialog 对象简介
'提供文件对话框，功能与 Microsoft Office 应用程序中标准的“打开”和“保存”对话框类似。
'利用这些对话框，解决方案的用户可以简便地指定解决方案中应该使用的文件和文件夹。
'“打开”对话框：让用户选择一个或多个可以在主机应用程序中使用 Execute 方法打开的文件。
'“另存为”对话框：让用户选择一个可以使用 Execute 方法保存当前文件的文件。
'“文件选取器”对话框：让用户选择一个或多个文件。用户选择的文件路径将捕获到 FileDialogSelectedItems 集合。
'“文件夹选取器”对话框：让用户选择一个路径。用户选择的文件路径将捕获到 FileDialogSelectedItems 集合。
'二 属性和方法
'1 AllowMultiSelect 如果允许用户从文件对话框中选择多个文件，则返回 True。Boolean 类型，可读写
'2 SelectedItems 选取的多个文件集合
'3 InitialFileName 属性:设置初始路径和文件名称
'4 InitialView 属性 :可以设置初始文件的显示样多
'5 show 可以判断用户是否点击了取消按钮,如果点击取消会返回0,否则返回-1
'选择并返回一组文件名和路径
Sub f1()
Dim f
Dim dig As Object
Set dig = Application.FileDialog(msoFileDialogOpen)
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = True
.Filters.Add "Excel文件", "*.xls", 1
.InitialFileName = ThisWorkbook.FullName '"d:"
.InitialView = msoFileDialogViewDetails
.Title = "对话框测试"
.Show
MsgBox .Show
For Each f In .SelectedItems
MsgBox f
Next f
End With
Set dig = Nothing
End Sub
'选择并返回文件夹
Sub F2()
Dim dig As Object
Set dig = Application.FileDialog(msoFileDialogFolderPicker)
With dig
.InitialFileName = "d:"
.Show
MsgBox .SelectedItems(1)
End With
Set dig = Nothing
End Sub
'
Sub t10()
Dim f
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = True
.Filters = "Excel表格,*.xls"
.InitialFileName = "测试.xls"
.FilterIndex = 1
.Title = "测试"
End With
End Sub
GetOpenFilename
Option Explicit
' 一、 概述基本语法
'GetOpenFilename相当于Excel打开窗口，通过该窗口选择要打开的文件，并可以返回选择的文件完整路径和文件名。
'注:此方法并不会真正打开文件?
'Application.GetOpenFilename(文件类型筛选规则,优先显示第几个类型的文件,标题,是否允许选择多个文件名)
'二、示例
'1 打开类型只限excel文件
'设置打开某类文件可以用下面的规则：
'"文件类型说明文字,*.文件类型后辍"
Sub t1()
Dim f
f = Application.GetOpenFilename("Excel文件,*.xls")
MsgBox f
End Sub
'2、打开多种文件类型(word和excel)
'打开多种文件类型，只需要用","隔开，添加新的文件类型说明和文件类型。
Sub t2()
Dim f
f = Application.GetOpenFilename("Excel2003文件,*.xls,Word文件,*.doc")
MsgBox f
End Sub
'3 打开多种文件类型,默认显示word文件
Sub t3()
Dim f
f = Application.GetOpenFilename("Excel2003文件,*.xls,Word文件,*.doc,文本文件,*.txt", 2)
MsgBox f
End Sub
'4 设置对话框名称
Sub t4()
Dim f
f = Application.GetOpenFilename("Excel2003文件,*.xls,Word文件,*.doc,文本文件,*.txt", 2, "选择要汇总的文件")
MsgBox f
End Sub
'5 选择多个文件,并以数组形式返回
Sub t5()
Dim f
ChDrive "E"
ChDir Application.Path
'ChDir ".."
f = Application.GetOpenFilename("Excel2003文件,*.xls,Word文件,*.doc,文本文件,*.txt", 1, MultiSelect:=True)
MsgBox f(1)
End Sub
GetSaveFilename
'GetSaveAsFilename语法:
' GetSaveAsFilename(默认显示的文件名,筛选条件,多个筛选类型时显示第几个,标题)
'注:该窗口也会有实质性的保存操作.只作为返回文件名的一个途径
Sub t1()
Dim f
f = Application.GetSaveAsFilename("示例.xls", "excel表格,*.xls", , "保存示例")
MsgBox f
End Sub
改变窗口默认路径
Option Explicit
'chdrive 盘符 可以改变默认驱动器
'chdir 路径 可以改变默认路径
Sub t6()
Dim f
ChDrive "E"
ChDir ThisWorkbook.Path
'ChDir ".."
f = Application.GetOpenFilename("Excel2003文件,*.xls,Word文件,*.doc,文本文件,*.txt", 1, MultiSelect:=True)
' MsgBox f(1)
End Sub
第35集：字符串的拆分、查找与转换
字符串拆与组合
Option Explicit
'字符串截取
'left,right,mid,Len
Sub z1()
Dim sr
sr = "Excel精英培训网"
Debug.Print Left(sr, 5)
Debug.Print Right(sr, 5)
Debug.Print Mid(sr, 3, 5)
Debug.Print Left(sr, Len(sr) - 1)
End Sub
'split
Sub z2()
Dim sr, arr
sr = "Excel的精的英的培训网"
arr = Split(sr, "的")
Debug.Print UBound(arr)
End Sub
'val
Sub z3()
Dim sr
sr = "89.90美元"
Debug.Print Val(sr)
End Sub
'字符串组合
'&
Sub a4()
Debug.Print "a" & "b"
End Sub
'join
Sub a5()
Dim sr, arr
sr = "Excel-精英-培训网"
arr = Split(sr, "-")
Debug.Print Join(arr, "+")
End Sub
字符串的查找与替换
Option Explicit
'instr 从前向后查
Sub c1()
Dim sr
sr = "Excel精英培训"
Debug.Print InStr(sr, "精英") > 0
End Sub
'InStrRev 从后向前
Sub c2()
Dim sr
sr = "Excel精英培训培训论坛"
Debug.Print InStr(sr, "培")
End Sub
'Replace替换
Sub c5()
Dim sr
sr = "Excel精英培训网"
sr = Replace(sr, "培训网", "论坛")
Debug.Print sr
End Sub
'mid语句替换
Sub c6()
Dim sr
sr = "Excel精英培训网"
Mid(sr, 8, 3) = "论坛"
Debug.Print sr
End Sub
字符转换
Option Explicit
'LCase 转换成小写
Sub z1()
Debug.Print LCase("ABC")
End Sub
'UCcae 转换成大写
Sub z2()
Debug.Print UCase("Abc")
End Sub
'StrConv 函数
'常数 值 说明
'vbUpperCase 1 将字符串文字转成大写。
'vbLowerCase 2 将字符串文字转成小写。
'vbProperCase 3 将字符串中每个字的开头字母转成大写
Sub 转换()
Debug.Print VBA.StrConv("wHo ARE you?", vbProperCase)
End Sub
Sub 转换2()
Dim i As Long
Dim x() As Byte
x = StrConv("ABCDEFG", vbFromUnicode) ' 转换字符串。
Debug.Print Application.Min(x)
For i = 0 To UBound(x)
Debug.Print x(i)
Next
End Sub
'TRim删除两端空格
'Ltrim 删除左边空格
'Rtrim 删除右边空格
Sub z3()
Dim sr
sr = " A B BC "
Debug.Print Trim(sr)
Debug.Print LTrim(sr)
Debug.Print RTrim(sr)
End Sub
'ASC 返回一个 Integer，代表字符串中首字母的字符代码,ANSI 字符集
'CHr 返回 String，其中包含有与指定的字符代码相关的字符
Sub z4()
Debug.Print Asc("Z")
Debug.Print Chr(90)
End Sub
'Space 和 string生成重复的字符
Sub z5()
Debug.Print "A" & Space(10) & "B"
Debug.Print "C" & String(10, "a") & "D"
End Sub
第36集：like运算符的使用
like对比字符串
Option Explicit
'like "对比的字符串"
'Option Compare Text
' 字符串1 like 字符串2
Sub L1()
Debug.Print "ABC" Like "ABc"
End Sub
'通配符?
'判断BA是不是长度为2，且第二个字符为A
Sub L2()
Debug.Print "BA" Like "?A"
End Sub
'通配符*
'判断字符串中是否包括cel
Sub L3()
Debug.Print "Excel精英培训" Like "*cel*"
End Sub
'判断含通配符的字符串
'把通配符放在[]内，就代表本身字符的对比
Sub l4()
'Debug.Print "QAB" Like "Q?B"
Debug.Print "QaB" Like "Q?B"
'Debug.Print "Q?B" Like "Q[?]B"
'Debug.Print ""
End Sub
'判断是指定位数数字
'判断数字是否为两个整数构成的
Sub l9()
Debug.Print 5 Like "#"
End Sub
'判断在某个区间的字符
Sub L10()
'[最小-最大最小2-最小3]
'Debug.Print "q" Like "[A-Za-z]" ' 判断q是不是字母
' Debug.Print "H" Like "[A-GM-Z]" ' 判断H是不是在A-G，M-Z区间
Debug.Print 8 Like "[!2-9]"
End Sub
'判断非在某个区间的字符
Sub L11()
Debug.Print "A" Like "[!C-Z]"
End Sub
'判断在列出的字符里
Sub L12()
Debug.Print "M" Like "[!ABCDEUE]"
End Sub
'判断A~C开头，F~G结尾
Sub L13()
Debug.Print "AEREM" Like "[A-C]*[L-P]"
Debug.Print "A334M" Like "[A-C]###[L-P]"
End Sub
实例
Option Explicit
Sub 求和()
Dim x, y, k
For x = 2 To 11
For y = 2 To 12
If Cells(y, 1) Like Cells(x, "F") Then
k = k + Cells(y, 2)
Range("a" & y).Interior.ColorIndex = 3
End If
Next y
Cells(x, "g") = k
Cells(x, "f").Interior.ColorIndex = 3
k = 0
Stop
Cells(x, "f").Interior.ColorIndex = xlNone
Range("a2:a12").Interior.ColorIndex = xlNone
Next x
End Sub
序号 求和类型 对比规则
1 包含A的数量 *A*
2 以A开头的数量 A*
3 以A~D开头的数量 [A-D]*
4 以A~D开头第2位是2的数量 [A-D]2*
5 以A~D开头第2位是7-9的数量 [A-D][7-9]*
6 第2位后全是数字的数量 ?#####
7 以E-G开头，m-x结尾的数量 [E-G]*[m-x]
8 第5位是字母的数量 ????[A-Za-z]?
9 包含？号的数量和 *[?]*
10 以非A~G的字符开始 [!A-G]*
第37集：正则表达式1
一 正则表达式
'正则表达式是处理字符串的外部工具，它可以根据设置的字符串对比规则，进行字符串的对比、替换等操作。
'正则表达式的作用：
'1、完成复杂的字符串判断
'2、在字符串判断时，可以最大限度的避开循环，从而达到提高运行效率的目的。
'二 使用方法
'1、引用法
'点击VBE编辑器菜单：工具 - 引用，选取: Microsoft VBScript Regular Expressions 5.5,引用后在程序开始进行如下声明
'Dim regex As New RegExp
Sub t1()
Dim reg As New RegExp
End Sub
'2、直接他建法
' 代码引用 (后期绑定)
' Dim regex As Object
' Set regex = CreateObject("VBScript.RegExp") '创建正则对象
Sub t2()
Dim reg As Object
Set reg = CreateObject("VBScript.RegExp")
End Sub
'三 常用属性
'1 Global属性:
'如果值为true,则搜索全部字符
'如果值为False,则搜索到第1个即停止
'1 例:
Sub t3()
Dim reg As New RegExp
Dim sr
sr = "ABCEA"
With reg
.Global = True
.Pattern = "A"
Debug.Print .Replace(sr, "")
End With
End Sub
'2 IgnoreCase 属性
'如果搜索是区分大小写的，为False（缺省值）True不分
'3 Pattern 属性
' 一个字符串，用来定义正则表达式。缺省值为空文本。
'4 Multiline 属性,字符串是不是使用了多行,如果是多行,$适用于每一行的最后一个
Sub t4()
Dim reg As New RegExp
Dim sr
sr = "AEA" & Chr(10) & "ABCA"
With reg
.Global = True
.MultiLine = True
'.Pattern = "A$"
.Pattern = "^A"
Debug.Print .Replace(sr, "")
End With
End Sub
'5 Execute 方法
'返回一个 MatchCollection 对象，该对象包含每个成功匹配的 Match 对象,
'返回的信息包括:
'FirstIndex:开始位置
'Length; 长度
'Value:长度
Sub t5()
Dim reg As New RegExp
Dim sr, matc
sr = "A454BCEA5"
With reg
.Global = True
.Pattern = "Ad+"
Set matc = .Execute(sr)
End With
Stop
End Sub
Function ns(rg)
Dim reg As New RegExp
Dim sr, ma, s, m, x
With reg
.Global = True
.Pattern = "d*.?d*"
Set ma = .Execute(rg)
For Each m In ma
s = s + Val(m)
Next m
End With
ns = s
' Stop
End Function
'6、Text方法
'返回一个布尔值，该值指示正则表达式是否与字符串成功匹配。其实就是判断两个字符串是否匹配成功
Sub t7()
Dim reg As New RegExp
Dim sr
sr = "BCR6EA"
With reg
.Global = True
.Pattern = "d+"
If .test(sr) Then MsgBox "字符串中含有数字"
End With
End Sub
入门例子
Function 提取中文(rg As String, k As Integer)
Dim regx As New RegExp
With regx
.Global = True
If k = 1 Then
.Pattern = "D"
ElseIf k = 2 Then
.Pattern = "w"
End If
提取中文 = .Replace(rg, "")
End With
End Function
第38集 正则表达式2
Option Explicit
'正则表达式的核心是设置对比的规则，也就是设置Pattern属性，而组成这些规则除了字符本身以外，是具有特定含义的符号。
'下面介绍的是正规表达式中常用符号的第一部分。
'号
'1.放在不便书写的字符前面,如换行符(r),回车符(n),制表符(t),自身(\)
'2.放在有特殊意义字符的前面,表示它自身,"$","^","."
'3.放在可以匹配多个字符的前面
'd 0~9的数字
'w 任意一个字母或数字或下划线，也就是 A~Z,a~z,0~9,_ 中任意一个
's 包括空格、制表符、换页符等空白字符的其中任意一个
'以上改为大写时,为相反的意思,如D 表示非数字类型
Sub t1()
Dim regx As New RegExp
Dim sr
sr = "AE45B646C"
With regx
.Global = True
.Pattern = "d" '排除非数字
Debug.Print .Replace(sr, "")
End With
End Sub
'.(点)
'可以匹配除换行符以外的所有字符
'+号
'+表示一个字符可以有任意多个重复的。
Sub t11()
Dim regx As New RegExp
Dim sr
sr = "A234CA7A"
With regx
.Global = True
.Pattern = "Ad+"
Debug.Print .Replace(sr, "")
End With
End Sub
'{}号
'可以设置重复次数
'1 {n} 重复n次
Sub t16()
Dim regx As New RegExp
Dim sr
sr = "A234CA7A67"
With regx
.Global = True
.Pattern = "d{5}" '连续两个数字
Debug.Print .Replace(sr, "")
End With
End Sub
'2 {m,n}最小重复m次,最多重复n次
Sub t22()
Dim regx As New RegExp
Dim sr
sr = "A234CA7A6789"
With regx
.Global = True
.Pattern = "d{4,5}" '连续两个数字或连续三个数字
Debug.Print .Replace(sr, "")
End With
End Sub
'3 {m,} 最少重复m次,相当于+
Sub t23()
Dim regx As New RegExp
Dim sr
sr = "A2348t6CA7A67"
With regx
.Global = True
.Pattern = "d{2,}" '连续两个数字或连续三个数字
Debug.Print .Replace(sr, "")
End With
End Sub
'* 可以出现0等任意次 相当于 {0,}，比如："^*b"可以匹配 "b","^^^b"...
' ?
'1 匹配表达式0次或者1次，相当于 {0,1}，比如："a[cd]?"可以匹配 "a","ac","ad"
Sub t24()
Dim regx As New RegExp
Dim sr
sr = "A23.48CA7A6..7"
With regx
.Global = True
.Pattern = "d+.?d+" '最多连续1个
Debug.Print .Replace(sr, "")
End With
End Sub
'2 利用+?的格式可以分段匹配
Sub t87()
Dim regex As New RegExp
Dim sr, mat, m
sr = "<td><p>aa</p></td> <td><p>bb</p></td>"
With regex
.Global = True
.Pattern = "<td>.*?</td>"
Set mat = .Execute(sr)
For Each m In mat
Debug.Print m
Next m
End With
End Sub
Sub t88()
Dim regex As New RegExp
Dim sr, mat, m
sr = " aba aca ada "
With regex
.Global = True
.Pattern = "s.+?s"
Set mat = .Execute(sr)
For Each m In mat
Debug.Print m
Next m
End With
End Sub
第39集：正则表达式3
其他常用符号
Option Explicit
'^符号：限制的字符在最前面,如^d表示以数字开头
Sub T34()
Dim regex As New RegExp
Dim sr, mat, m
sr = "d234我345d43"
With regex
.Global = True
.Pattern = "^d*"
Set mat = .Execute(sr)
For Each m In mat
Debug.Print m
Next m
End With
End Sub
'$符号：限制的字符在最后面，如 A$表示最后一个字符是A
Sub T3433()
Dim regex As New RegExp
Dim sr, mat, m
sr = "R243r"
With regex
.Global = True
.Pattern = "^D.*D$"
Set mat = .Execute(sr)
For Each m In mat
Debug.Print m
Next m
End With
End Sub
'b
'空格(包含开头和结尾)
Sub t26()
Dim regx As New RegExp
Dim sr
sr = "A12dA56 A4"
With regx
.Global = True
.Pattern = "bAd+"
Debug.Print .Replace(sr, "")
End With
End Sub
Sub T272()
Dim regex As New RegExp
Dim sr, mat, m
sr = "ad bf cr de ee"
With regex
.Global = True
.Pattern = ".+?b"
Set mat = .Execute(sr)
For Each m In mat
If m <> " " Then Debug.Print m
Next m
End With
End Sub
'|
'可以设置两个条件,匹配左边或右边的
Sub t27()
Dim regx As New RegExp
Dim sr
sr = "A12DA56 A4B34D"
With regx
.Global = True
.Pattern = "Ad+|Bd+"
Debug.Print .Replace(sr, "")
End With
End Sub
'un 匹配 n，其中 n 是以四位十六进制数表示的 Unicode 字符。
'汉字一的编码是4e00,最后一个代码是9fa5
Sub t2722()
Dim regx As New RegExp
Dim sr
sr = "A12d我A爱56你 A4"
With regx
.Global = True
.Pattern = "[u4e00-u9fa5]"
Debug.Print .Replace(sr, "")
End With
End Sub
小括号的作用
Option Explicit
'()
'可以让括号内作为一个整体产生重复
Sub t29()
Dim regx As New RegExp
Dim sr
sr = "A3A3QA3A37BDFE87A8"
With regx
.Global = True
.Pattern = "((A3){2})" '相当于A3A3
Debug.Print .Replace(sr, "")
End With
End Sub
'取匹配结果的时候，括号中的表达式可以用 数字引用
Sub t30()
Dim regx As New RegExp
Dim sr
sr = "A3A3QA3A37BDFE87A8"
With regx
.Global = True
.Pattern = "((A3){2})Q1"
Debug.Print .Replace(sr, "")
End With
End Sub
Sub t31()
Dim regx As New RegExp
Dim sr
sr = "A3A3B4B4QB4B47BDFE87A8"
With regx
.Global = True
.Pattern = "((A3){2})((B4){2})Q4"
Debug.Print .Replace(sr, "")
End With
End Sub
'用(?=字符)可以先进行预测查找，到一个匹配项后，将在匹配文本之前开始搜索下一个匹配项。 不会保存匹配项以备将来之用。
'例：截取某个字符之前的数据
Sub t343()
Dim regex As New RegExp
Dim sr, mat, m
sr = "100元8000元57元"
With regex
.Global = True
.Pattern = "d+(?=元)" '查找任意多数字后的元，查找到后从元以前开始查找（因为元前的数字已被使用，
'所以只能从元开始查找）匹配 ()后面的，因为后面没有设置，所以只显示前面的数字，元不再显示
Set mat = .Execute(sr)
For Each m In mat
Debug.Print m
Next m
End With
End Sub
'例：验证密码，条件是4-8位，必须包含一个数字
Sub t355()
Dim regex As New RegExp
Dim sr, mat, m
sr = "A8ayaa"
With regex
.Global = True
.Pattern = "^(?=.*d).{4,8}$"
Set mat = .Execute(sr)
For Each m In mat
Debug.Print m
Next m
End With
End Sub
'用(?!字符)可以先进行负预测查找，到一个匹配项后，将在匹配文本之前开始搜索下一个匹配项。 不会保存匹配项以备将来之用。
Sub t356()
Dim regex As New RegExp
Dim sr, mat, m
sr = "中国建筑集团公司"
With regex
.Global = True
.Pattern = "^(?!中国).*"
Set mat = .Execute(sr)
For Each m In mat
Debug.Print m
Next m
End With
End Sub
'()与|一起使用可以表示or
Sub t344()
Dim regex As New RegExp
Dim sr, mat, m
sr = "100元800块7元"
With regex
.Global = True
.Pattern = "d+(元|块)"
'.Pattern = "d+(?=元|块)"
Set mat = .Execute(sr)
For Each m In mat
Debug.Print m
Next m
End With
End Sub
中括号的作用
Option Explicit
'[]
'使用方括号 [ ] 包含一系列字符，能够匹配其中任意一个字符。用 [^ ] 不包含一系列字符，
'则能够匹配其中字符之外的任意一个字符。同样的道理，虽然可以匹配其中任意一个，但是只能是一个，不是多个
'1 和括号内的其中一个匹配
Sub t29()
Dim regx As New RegExp
Dim sr
sr = "ABDC"
With regx
.Global = True
.Pattern = "[BC]"
Debug.Print .Replace(sr, "")
End With
End Sub
'2 非括号内的字符
Sub T35()
Dim regx As New RegExp
Dim sr
sr = "ABCDBDC"
With regx
.Global = True
.Pattern = "[^BC]"
Debug.Print .Replace(sr, "")
End With
End Sub
'3 在一个区间
Sub t38()
Dim regx As New RegExp
Dim sr
sr = "ABCDGWDFUFE"
With regx
.Global = True
.Pattern = "[a-h]"
Debug.Print .Replace(sr, "")
End With
End Sub
Sub t40()
Dim regx As New RegExp
Dim sr
sr = "124325436789"
With regx
.Global = True
.Pattern = "[1-47-9]"
Debug.Print .Replace(sr, "")
End With
End