目录

第1集：宏与VBA

1什么是VBA，它有什么作用

2 VBA在哪里存放的？怎么运行的

3、什么是宏？宏和VBA有什么关系？

4、录制一个宏

5、编写第一个宏

第2集：VBA中的语句、对象、方法与属性

一、VBA属性

二、VBA方法

三、VBA对象

四VBA语句

第3集：循环语句

if判断语句

select判断

判断范围

第4集：判断语句

第5集：VBA变量

第6集：函数与公式

‘一、在单元格中输入公式

‘二、利用单元格公式返回值

‘三、借用工作表函数

‘四、利用VBA函数

‘五、编写自定义函数

第8集：VBA分支与End语句

‘一、END语句

‘二、Exit语句

分支语句

第7集：VBE编辑器

‘一、VBE的窗口

第9集：excel文件操作

excel文件的操作

excel文件的几个概念

第10集：excel工作表操作

工作表文件的操作

excel工作表的分类

第11集：单元格选取

‘1表示一个单元格(a1)

‘2表示相邻单元格区域

‘3表示不相邻的单元格区域

‘4表示行

‘5表示列

‘6重置坐标下的单元格表示方法

‘7表示正在选取的单元格区域

第12集：特殊单元格定位

‘1已使用的单元格区域

‘2某单元格所在的单元格区域

‘3两个单元格区域共同的区域

‘4调用定位条件选取特殊单元格

‘5端点单元格

实例

第13集：单元格信息

‘1单元格的值

‘2单元格的地址

‘3单元格的行列信息

‘4、单元格的格式信息

‘5、单元格批注信息

‘6单元格的位置信息

‘7单元格的上级信息

‘8内容判断

‘9单元格数据类型（另讲）

第14集：单元格的格式

‘一、判断数值的格式

‘二、设置单元格自定义格式

单元格合并

‘综合示例

第15集：单元格编辑示例

单元格输入

第16集：单元格查找

单元格查询

入库单实例

第17集：excel事件程序(上)

第18集：工作簿事件

第19集：excel程序事件

第20集：VBA数组-1：数组基础

第1_了解VBA运算特点

第2_什么是VBA数组

第3_VBA数组的写入

第21集：BA数组-2读取

第1_了解VBA运算特点

第2_什么是VBA数组

第3_VBA数组的写入

第4_VBA数组的读取

第22集：数组-3

第5_数组的空间

第23集：数组-4：数组与函数

可以生成数组的函数

数组的处理

第24集：VBA数组-5：数组与单元格格式

‘数组也可以设置格式？

第25集：VBA数组之VBA排序算法(上)

插入排序

快速排序

递归快速排序

冒泡排序

第26集：VBA数组-7：VBA排序算法之插入排序和希尔排序

第27集：VBA字典-1

‘1什么是VBA字典？

‘2即然有数组，为什么还要学字典？

‘3字典有什么局限？

‘4字典在哪里？如何创建字典？

字典的使用

第28集：VBA字典-2

字典与查找

字典与求和

字典与唯一值

第29集：VBA数组与字典综合应用之下棋法（兰色原创）

多列汇总

多条件多列汇总

数据透视式汇总

第30集：自定义函数基础

什么是自定义函数

编写和使用自定义函数

自定义函数的常见问题

第31集：自定义函数的参数设置

第32集：Msgbox函数完全应用

Msgbox函数简介

‘二、基本语法

设置信息框上的帮助

特殊值及含义说明

第33集：Inputbox函数方法应用

基本应用

Inputbox语法概述

Inputbox的扩展应用

第34集：调用Excel对话框

‘一FileDialog对象简介

GetOpenFilename

GetSaveFilename

第35集：字符串的拆分、查找与转换

字符串拆与组合

字符转换

第36集：like运算符的使用

实例

序号求和类型对比规则

第37集：正则表达式1

一正则表达式

‘二使用方法

‘三常用属性

入门例子

第38集正则表达式2

第39集：正则表达式3

其他常用符号

第40集：正则表达式4

第41集：正则表达式5

第42集：数据类型转换

数据类型

数据类型检查

数据类型转换

第43集：时间与日期

第45集：随机抽取之移形换位法

第46集：组合之递归算法

第47集：VBA程序提速

第48集：基本操作

‘遍历指定文件夹中的文件

第49集：文件夹遍历

父子转换法

第50集：VBA压缩文件和解压缩

一_压缩文件

二_压缩文件的路径

三_添加压缩密码

四_压缩后删除源文件

五_压缩时排除

六_文件批量单独压缩

七_从压缩包中删除指定文件

八_解压缩

第51 txt读写

第52集：Txt文件的读取

第53集：窗体与控件基础

第54集：窗体事件

第55集：标签、按钮

第56集：文字框

第57集：列表和组合框

第58集：单选复选和框架和多页

第59、60集：Listview控件

第61集：日期和进度条

第62集：窗体综合实例

第63集：命令栏操作之命令栏

第64集：命令栏操作之自定义命令

第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 100for 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

2End 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，本列允许为重复

‘Keyitem

‘A10

‘B20

‘C30

‘Z10

‘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:\WINDOWS\Help路径下

‘第五个参数和帮助文件本身有关,是为了准备的打开帮助文件而设置的上下文编号,如果没有则设置为0

Sub test13()

Dim x

x = MsgBox(“测试添加帮助的效果”, vbOKCancel + vbMsgBoxHelpButton, “测试帮助!”, “D:/a.chm”, 0) ‘”C:\WINDOWS\Help\excel.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

特殊值及含义说明

常数值描述

vbOKOnly0只显示确定按钮

VbOKCancel1显示确定及取消按钮。

VbAbortRetryIgnore2显示放弃、重试及忽略按钮。

VbYesNoCancel3显示是、否及取消按钮。

VbYesNo4显示是及否按钮。

VbRetryCancel5显示重试及取消按钮。

VbCritical16危险图标

VbQuestion32询问图标

VbExclamation48警告图示

VbInformation64信息图标

vbDefaultButton10第一个按钮是缺省值。

vbDefaultButton2256第二个按钮是缺省值。

vbDefaultButton3512第三个按钮是缺省值。

vbDefaultButton4768第四个按钮是缺省值。

vbApplicationModal0应用程序强制返回；应用程序一直被挂起，直到用户对消息框作出响应才继续工作。

vbSystemModal4096系统强制返回；全部应用程序都被挂起，直到用户对消息框作出响应才继续工作。

vbMsgBoxHelpButton16384将Help按钮添加到消息框

VbMsgBoxSetForeground65536指定消息框窗口作为前景窗口,就是显示在窗口的最上层

vbMsgBoxRight524288文本为右对齐

vbMsgBoxRtlReading1048576指定文本应为在希伯来和阿拉伯语系统中的从右到左显示

常数值说明

vbOK1确定

vbCancel2取消

vbAbort3终止

vbRetry4重试

vbIgnore5忽略

vbYes6是

vbNo7否

第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

‘5Execute方法

‘返回一个MatchCollection对象，该对象包含每个成功匹配的Match对象,

‘返回的信息包括:

‘FirstIndex:开始位置

‘Length;长度

‘Value:长度

Sub t5()

Dim reg As New RegExp

Dim sr, matc

sr = “A454BCEA5”

With reg

.Global = True

.Pattern = “A\d+”

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 = “A\d+”

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 = “

aa

bb

“

With regex

.Global = True

.Pattern = “

“

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 = ” abaacaada “

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 = “\bA\d+”

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 = “A\d+|B\d+”

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})Q\1”

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})Q\4”

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