VBA学习笔记

EXCEL之VBA

学习笔记

：磊

时间：2015年9

1 / 52

.

目录

第一章 VBA根底知识3

第二章工作簿以及工作表的操作9 第三章：单元格区域操作14 第四章：事件程序:36 第五章：VBA数组43

2 / 52

.

第一章 VBA根底知识

1：代码帮助： F1

2：代码换行： 下划线+空格+回车 3：.常用代码操作excel中的对象

〔1〕、工作簿〔Workbooks〕 Workbooks〔N〕第N个工作簿 Workbooks (\"工作簿名\") ActiveWorkbook 活动工作簿 ThisWorkBook 代码所在工作簿

〔2〕、工作表〔Worksheets〕 Sheets(N) 第N个工作表 Sheets(\"工作表名\") SheetN 第N个工作表 ActiveSheet 活动工作表 worksheets 与 Sheets的区别

〔3〕、 单元格〔cells〕 Range (\"单元格地址\") Cells(行号,列号) [A1]单元格简写 Activecell 活动单元格 Selection 当前被选取的区域 4：常量与变量

〔1.〕常量：常量是定义了之后就不做变化了。 常量定义格式：Const 常量名= 常量表达式 〔2〕.变量:在定义之后还能再次赋值 变量定义格式：Dim 变量 As 变量类型

5：数据类型

〔1.〕VBA中的常见数据类型：

类型 注释 简写 占用存 Integer 整型 % 2Byte Single 单精度 ! 4Byte Double 双精度 # 8Byte Long 长整型 & 4Byte

String 字符型 $ 定长或变长( 变长字符串最

多可包含大约

20 亿 ( 2^31)个字符。 定长字符串可包含 1 到大约 K ( 2^16 ) 个

字符。)

Currency 货币型 8Byte 6:if条件语句

1.单行形式1〔If...Then〕

3 / 52

.

If 条件判断 Then 条件成立结果

注意 在单行形式中，按照 If...Then 判断的结果也可以执行多条语句。 所有语句必须在同一行上并且以冒号分开? 例子: Sub test()

If 1 > 10 Then a = a + 1: b = 1 + a: c = 1 + b End Sub

2. 单行形式1〔If 条件判断 Then 条件成立 Else 条件不成立〕 例子: Sub test2()

If 1 > 1 Then MsgBox \"yes\" Else MsgBox \"no\" End Sub

3.块形式〔If...Then…End〕 If 条件判断 Then 条件成立结果 End If 例子: Sub test3() If 11 > 10 Then a = 1 + a b = 1 + a c = 1 + b End If End Sub

4.块形式的If嵌套

If 条件判断 Then

成立时的结果

ElseIf 条件判断 Then

成立时的结果

……

Else

不成立时的结果

4 / 52

.

End If 例子:

Sub 等级判断()

If Sheet1.Range(\"b1\") >= 90 Then Sheet1.Range(\"b2\") = \"优\" ElseIf Sheet1.Range(\"b1\") >= 80 Then Sheet1.Range(\"b2\") = \"良\" ElseIf Sheet1.Range(\"b1\") >= 70 Then Sheet1.Range(\"b2\") = \"中\" Else

Sheet1.Range(\"b2\") = \"差\" End If End Sub

7：select语句用于判断选择

Selectcase Case1 Case2 ….. Case else End select

8：循环语句

〔1〕：doloop语句 Do ….. Loop

(2):do while loop语句 Do while (条件成立时候循环) Loop

〔3〕do until loop 语句 Do until (直到条件成立) Loop

[注]：while与until不但可以放在DO后面，也可以放在LOOP后面事实上有时在循环的最后

一行进展判断，更具有意义。

Do [{While | Until} 表达式] [执行的一条或多条语句] [Exit Do]

[执行的一条或多条语句] Loop

--------------------------------------------------------------------------------- while：当这个条件为True时就 循环 until：直到这个条件为True时就 跳出循环

---------------------------------------------------------------------------------

5 / 52

.

或者可以使用下面这种语法: Do

[执行的一条或多条语句] [Exit Do]

[执行的一条或多条语句] Loop [{While | Until}表达式]

--------------------------------------------------------------------------------- 用Do…Loop循环要注意的几点:

1. While与Until是放在Do后面还是Loop后面，取决于是先判断再循环，还是先循环再判

断。前者那么在Do后面，后者那么在Loop后面。

2. 可以在Do...Loop中的任何位置放置任意个数的 Exit Do 语句，随时跳出 Do...Loop 循

环。

3. Do...Loop + If...Then + Exit Do 通常结合使用.

4. 如果 Exit Do 使用在嵌套的 Do...Loop 语句中，那么 Exit Do 会将控制权转移到 Exit

Do 所在位置的外层循环。

〔4〕：for each next 语句 Eg:

Sub foreachnext循环1()

Dim rng As Range, n! (range为单元格对象)

For Each rng In Sheet1.Range(\"a2:a10\") 取a2:a10中的每个单元格 Next End Sub

Sub foreachnext循环2()

Dim wsh As Worksheet, n As Byte, m As String 〔worksheet为工作表变量〕 For Each wsh In Worksheets 取当前工作表集合中的每个成员 n = n + 1

Sheet1.Cells(n, 3) = wsh.Name Next End Sub

9：exit语句与end语句

〔1〕： exit是退出当前语句

1.Exit Do 2.Exit For 3.Exit Function

4.Exit Sub

〔2〕：完毕一个过程或块 End

End Function

End If

End Select End Sub

6 / 52

.

[注]：end有时候在某些地方的功能和exitfor的作用一样。 10：跳转语句

GoTo line无条件地转移到过程中指定的行。 Gosub return 跳转到某行，而且能够返回。

注意太多的 GoTo 语句，会使程序代码不容易阅读及调试。尽可能使用结构化控制语句(Do...Loop、For...Next、If...Then...Else、Select Case)。 Forexample Sub gotoreturn() Dim i!

For i = 2 To 10

If Sheet1.Range(\"a\" & i) > 1 / 3 Then GoSub 100 Next i Exit Sub

100: (作为gosub的跳转标示符号) Sheet1.Range(\"b\" & i) = \"迟到\" Return 〔return语句返回到跳转的地方〕 End Sub

11：对错误语句的处理

方法1：

On Error Resume Next 当错误的时候继续执行下去 方法2：

On Errorgoto当错误时候去哪儿。

12：with语句

当对某个对象执行一系列的语句时，不用重复指出对象的名称。 For example Sub with嵌套1()

Range(\"a1\").Value = \"Who am i ?\" Range(\"a1\").Parent.Name = \"Hello World\" Range(\"a1\").Font.Size = 20 Range(\"a1\").Font.Bold = True End Sub

Sub with嵌套2() With Range(\"a1\")

.Value = \"Who am i ?\" .Parent.Name = \"Hello World\" With .Font .Size = 20 .Bold = True End With End With End Sub

13:VBA 与公式

For example Sub 普通公式()

7 / 52

.

Sheet1.Cells(1, 3) = \"=a1+b1\" End Sub

Sub 批量计算() Dim i As Integer For i = 1 To 10

Sheet1.Cells(i, 4) = \"=a\" & i & \"+b\" & i Next i End Sub

Sub 数组公式()

Range(\"e1:e10\").FormulaArray = \"=a1:a10+b1:b10\" (FormulaArray为数组公式) End Sub

Sub 公式带引号的计算()

Cells(12, 1) = \"=COUNTIF(A1:A10,\"\">9\"\")\" 〔如果公式当中含有引号，那么需要添加双重引号，才能够使公式的输入格式正确〕

Cells(12, 2) = \"=sum(INDIRECT(\"\"a1:a10\"\"))\" End Sub

14:运算符

运算符是代表VBA某种运算功能的符号。

1〕赋值运算符 :=

2〕数算符: &(字符连接符)、+(加)、-〔减〕、Mod〔取余〕、\\〔整除〕、*〔乘〕、/〔除〕、-〔负号〕、^〔指数〕

3〕逻辑运算符:Not〔非〕、And〔与〕、Or(或)、Xor(异或 一样为0，不同为1)、Eqv(相等，一样为1，不同为0)、Imp(隐含)

4〕关系运算符: = 〔一样〕、<>〔不等〕、>〔大于〕、<〔小于〕、>=〔不小于〕、<=〔不大于〕、Like〔判断两个字符串是否一样〕 ?：代表任何单一字符 *：代表零个或多个字符。

[charlist] ：代表charlist.中的任何单一字符? [!charlist] ：代表不在 charlist 中的任何单一字符。

8 / 52

.

第二章 工作簿以及工作表的操作

1：VBA 中工作表与工作簿的表示方法

1： workbooks(“工作表的文件名〞)

Workbooks(“工作表的文件名〞).parent 返回工作簿对象的父对象 2：工作簿引索号表示法

workbooks(数字).name返回工作表的名称 3：窗口表示方法

Windows.count返回当前excel工作簿翻开的个数 Windows(N).parent.Name 返回第N个工作簿的名称

[注：工作簿索引号的表示法与窗口表示法表示的工作簿的顺序相反。]

2：当前工作簿与活动工作簿

当前工作簿：thisworkbook代码所在工作簿 活动工作簿：activeworkbook已经激活的工作簿

[注]：当前工作簿可能是已经激活的工作簿，也可能不是已经激活的工作簿。

3：工作簿的根本操作

workbooks由当前所有在存中翻开的workbook对象组成的集合 〔1〕：.新建工作簿 Sub 新建工作簿()

Dim wkb As Workbook 声明wkb为工作簿 Set wkb = Workbooks.Add 新建工作秒簿 wkb.SaveAs \"c:\\123.xls\" 保存为工作簿 End Sub 〔2〕.翻开工作簿 Sub 翻开工作簿() Dim wkb As Workbook

Set wkb = Workbooks.Open(\"c:\\123.xls\") End Sub

〔3〕.关闭工作簿 Sub 关闭()

Workbooks(\"123\").Close True (默认为自动保存，不提示) End Sub

〔4〕.文件复制与删除 Sub 文件复制与删除()

FileCopy \"c:\\123.txt\〔对所有文件类型都起作用〕 Kill \"c:\\321.txt\" End Sub

4：工作薄的应用实例 （1） 判断文件是否存在

Sub 文件是否存在()

9 / 52

.

a = Dir(\"c:\\123.xls\") 〔Dir函数用来取出路径下的目录文件〕 If a = \"\" Then MsgBox \"不存在\" Else

MsgBox \"存在\" End If End Sub

（2） 翻开指定目录下的文件

Sub 翻开指定目录下的文件() Dim a$, n!, wbs As Workbook a = Dir(\"c:\\*.txt\") Workbooks.Open \"c:\\\" & a Do

a = Dir

If a <> \"\" Then

Workbooks.Open \"c:\\\" & a Else

Exit Sub End If Loop End Sub

5：工作簿的表示方法

在workbook对象中，有一个SHEETS集合,其成员是worksheet对象或chart对象。 worksheets仅指的是工作表，而sheets包含图表，工作表，宏表等等 VBA中，经常在工作表之间转换或者对不同工作表中的单元格区域进展操作. 通常有下面几种方法:

〔1〕：Sub 直接使用工作表名称法()

MsgBox Worksheets(\"我的工作表\").Name MsgBox Sheets(\"我的图表\").Name End Sub

〔2〕Sub 索引号表示法()

MsgBox Worksheets(1).Name End Sub

〔3〕Sub 工作表代码索引号表示法()

MsgBox Sheets(1).Name End Sub

〔4〕Sub 直接取工作代码法()

MsgBox Sheet1.Name End Sub

〔5〕Sub 活动工作表()

MsgBox ActiveSheet.Name End Sub

注意：当工作簿包括工作表、宏表、图表等时， 使用索引号引用工作表如Sheets(1)与

10 / 52

.

WorkSheets(1)引用的可能不是同一个表。 Sub worksheetss() MsgBox Worksheets(1).Name MsgBox Sheets(1).Name End Sub Sub sheetss()

For i = 1 To Sheets.Count MsgBox Sheets(i).Name Next End Sub

6：工作表集合的应用

〔1〕Sub 遍历sheets下的所有对象()

For Each shs In Sheets k = k + 1

Cells(k, 1) = shs.Name Next End Sub

〔2〕Sub 遍历worksheets下的所能对象()

For Each shs In Worksheets k = k + 1

Cells(k, 2) = shs.Name Next End Sub

〔3〕Sub 工作表存在与否()

Dim sn$

For Each sht In Sheets sn = sht.Name

If sn = \"我的工作表\" Then MsgBox \"存在\" Exit Sub End If Next

MsgBox \"不存在\" End Sub

〔4〕Sub 工作表存在与否1()

Dim sn$

For i = 1 To Sheets.Count 〔Sheets.Count指sheet里面的数量〕 a = Sheets(i).Name

If Sheets(i).Name = \"我的工作表\" Then MsgBox \"存在\" Exit Sub End If

11 / 52

.

Next

MsgBox \"不存在\" End Sub

7：工作表的增加与删除

Sheets.Add 方法

表达式.Add(Before, After, Count, Type)

XlSheetType 常量之一: xlWorksheet 工作表 xlChart 图表

xlExcel4MacroSheet 宏表 xlExcel4IntlMacroSheet 对话框 默认值为 xlWorksheet?

Sub 新建sheets()

Sheets.Add 〔默认在活动工作表之前添加一个工作表〕

Sheets.Add Sheets(\"abc\") 〔在工作表名为ABC的工作表之前添加一个工作表〕 Sheets.Add , Sheets(\"abc\") 〔在工作表名为ABC的工作表之后添加一个工作表〕 Sheets.Add after:=Sheets(\"abc\") 〔与上式等价〕

Sheets.Add Count:=2 〔在活动工作表前添加两个工作表〕 Sheets.Add , , 2 〔与上式等价〕 Sheets.Add , , , xlChart 〔添加图表〕 End Sub

Sub 删除工作表() Sheet10.Delete End Sub

8：工作表的删除与添加

如果想批量新建工作表，可以结果循环来制作

Sub 新建1到12月份的工作表() Dim j%

For j = 12 To 1 Step -1 Next End Sub

'删除工作表 Sub 删除sheet()

On Error Resume Next 〔当出现错误时候忽略错误〕

Application.DisplayAlerts = False 〔当屏幕有警告提示时候忽略开启〕 Dim i%

For i = 1 To 12

Sheets(i & \"月\").Delete Next

12 / 52

.

Application.DisplayAlerts = True 〔当屏幕有警告提示时候忽略关闭，否那么，下

次运行代码时候依旧是忽略关闭状态〕

End Sub

9：工作表的移动与复制 （1） 工作表的复制

表达式.copy(Before, After) Sub 复制()

Sheet1.Copy Sheets(Sheets.Count) End Sub

（2） 工作表的移动

'表达式.Move(Before, After) Sub 移动()

Sheet1.Move , Sheet3 End Sub

10：工作表的选择与激活

Worksheet.Select 方法 不支持隐藏选取

Worksheet.Activate 方法 支持隐藏选取

〔1〕： Sub 快速选择所有工作表()

Worksheets.Select 〔只选择工作表〕

Sheets.Select 〔工作表，图表等全部选择〕 End Sub

〔2〕：Sub 自定义选择()

Worksheets(Array(1, 3, 5)).Select End Sub

11：拆分工作簿实例

Sub 拆分到工作簿()

Dim wk As Workbook, ss$, k% 声明wk为一个工作簿类型变量 Application.DisplayAlerts = False

For Each sht In Workbooks(\"2-11.工作簿综合运用(拆分工作簿)\").Sheets

Set wk = Workbooks.Add wk为一个对象，对象的方法为添加工作

表

k = k + 1

Workbooks(1).Sheets(k).Copy Workbooks(2).Sheets(1) ss = ThisWorkbook.Path & \"\\\" & sht.Name & \".xlsx\" wk.SaveAs ss wk.Close Next

Application.DisplayAlerts = True MsgBox \"拆分工作簿完成！\" End Sub

13 / 52

.

第三章：单元格区域操作

1：range对象

单元格对象在VBA中一个非常根底，同时也很重要的。它的表达方式也是非常的多样化。 Range 对象

代表某一单元格、某一行、某一列、某一选定区域〔该区域可包含一个或假设干连续单元格区域〕，或者某一三维区域。

Range (\"文本型装单元格地址\")

range的常见写法 Sub rng()

Range(\"a1\").Select 单元格 Range(\"a:a\").Select 列 Range(\"1:3\").Select 行 Range(\"a1:b10\").Select 相邻区域 Range(\"a1:d7,c4:e8\").Select 不相个邻区域 Range(\"a1:d7 c4:e8\").Select 相交的区域 End Sub

2：range的其他写法

Range(\"a1:b10\").Select '一般写法 Range(\"a1\变化写法1

Range(Range(\"a1\"), Range(\"b10\")).Select '变化写法2 〔方便以后可以使用变量替换〕 Range(\"a1\") = 123 〔给单元格赋值〕 注意：

1.如果在range前没有指定工作表，那么默认为活动工作表 2.如果对象不是活动工作表〔如活动图表〕，那么会出现错误

Sub 单元格对象例子()

Debug.Print Range(\"a:a\").Count '计数工作表最大的行数〔Debug.Print

意思是在活动窗口中显示出来〕

Debug.Print Range(\"1:1\").Count '计算工作表最大的列数

Debug.Print Application.CountA(Range(\"a:a\")) '计算工作表已使用的行数 Debug.Print Application.CountA(Range(\"1:1\")) '计算工作表已使用的列数 End Sub

3：range变量与引用

〔1〕：range的变化写法

1):range(\"地址区域\").range(\"地址区域\")

Sub 序号表示法()

14 / 52

.

Range(\"b2:d4\").Range(\"b2\").Select '相对引用的写法 '参照前一个range的左上单元格 End Sub

2):2.range地址区域中支持变量

Sub range的变量支持() Dim a% a = 3

Range(\"a\" & a).Select Range(\"c3:e5\")(2).Select End Sub 3):动态引用实例

Sub 实例1动态选单元格或区域() Dim i%

i = Application.CountA(Range(\"c:c\")) '找到c列中已使用的最后一个单元格位置 Range(\"c\" & i).Select '选择C列最后一格

Range(\"a1\选择A1到C列的最后一格〔方法一〕 Range(\"a1:c\" & i).Select '选择A1到C列的最后一格〔方法二〕 小结：动态单元格区域的定位，可以应用到单据的保存等实际工作中 End Sub

4：Range引用与索引

range区域中的每个单元格，我们也可以用索引号表示出来 写法：range(\"单元格区域\")(行号，列号) Sub 索引号取出range的单元格()

'Range(\"a1:c4\")(4).Select '引用顺序是：从左向右，从上到下选取 'Range(\"b2:c4\")(3).Select '以前一个单元格区域为照 Range(\"a1:c4\")(4.5).Select '当有小数时，那么取整

'注意：如果索引号出现小数，那么按照“四舍六入五单双〞的“银行家舍入法〞 End Sub

Sub 行列号定位()

Range(\"a1:c4\")(3, 2).Select '利用行号与列号定位 Range(\"a1:c4\")(1.5, 2.5).Select '行列号也可以使用小数

5：cells单元格的引用

cells单元格引用法 写法：cells(行号,列号) Sub cells根本写法()

Cells(3, 4).Select '行列号均为数字

Cells(2, \"c\").Select '行为数字，列为列标字母 Cells.Select '全选 End Sub

'cells可以像range一样可以参照前面的单元格位置 Sub 参照写法()

Range(\"b3:f11\").Cells(2, 2).Select

Range(\"b3:f11\").Cells(6).Select '从左到右，从上到下

15 / 52

.

Range(\"b3:f11\")(6).Select '与上一句相等 End Sub '注意：

'1.cells中的数字一样支持正数，负数，0值，小数(四舍六入五单双) '2.cells不能像range一样可以引用一个区域，只能引用一个单元格

6：单元格简写

除了前面讲的range\\cells单元格区域的表示方法还，还是一种简单的写法 '写法: [单元格地址] '注意：中括号中的单元格地址并不需要双引号(\"\") Sub 单元格简写()

[a3].Select ' 单元格引用 [b2:c6].Select '单元格区域引用 [a3,b2:c6,b8:d12].Select '多区域引用 [a:a].Select '整列引用 [1:1].Select '整行引用 End Sub

'单元格简写的也支持引用子集 Sub 子集引用() [b2:c6].Item(3).Select Range(\"b2:c6\")(3).Select [b2:c6].Cells(4).Select End Sub

Sub 动态区域的引用()

a = Application.CountA([a:a]) b = Application.CountA([1:1])

Range(Range(\"a1\"), Range(Chr( + b) & a)).Select '利用chr函数，让字母形式的列号也

支持变量

End Sub

Sub chr函数字符循环() For i = 1 To 65535 Cells(i, 1) = i Cells(i, 2) = Chr(i) Next End Sub

7：三种单元格引用小结

功能 引用对象 变量支持 书写难易 Range 单元格，区域，行，列 支持 难 Cells 单元格 支持 难 [单元格地址] 单元格，区域，行，列 不支持 易 Range(\"a1:c\" & i).Select '引用单元格是区域且有变量 Cells(i, \"c\").Select '引用的是单个单元格且有变量

16 / 52

.

[a1:19].Select '引用的是区域或单元格且无变量

8：行列的引用

'行列引用 Sub 列引用() Columns(1).Select

Columns(\"b\").Select 〔b列〕 Columns(\"c:e\").Select 〔c到e列〕 End Sub

Sub 行引用() Rows(1).Select Rows(\"2\").Select

Rows(\"3:4\").Select 〔3到4行〕 End Sub

Sub range行列表式法()

Range(\"1:1\").Select 〔第一行〕 Range(\"2:4\").Select 〔2到4行〕 Range(\"a:a\").Select 〔a列〕 Range(\"b:d\").Select 〔B到D列〕 End Sub Sub 简写法() [a:a].Select [b:d].Select [1:1].Select [2:4].Select End Sub

Sub 全选()

Rows.Select '选择所有行 Columns.Select '选择所有列 Cells.Select '选择所单元格 i = Rows.Count j = Columns.Count k = Cells.Count End Sub

Sub 动态引用使用区域()

a = Application.CountA(Columns(1)) 〔返回第一列当中使用的〔非空〕单元格数目〕 b = Application.CountA(Rows(1)) 〔返回第一行中使用的〔非空〕单元格数目〕 Range(\"a1\〔动态引用单元格〕 End Sub

9: row与column属性

Range.Row 属性

'返回区域中第一个子区域的第一行的行号

17 / 52

.

'Range.Column 属性

'返回指定区域中第一块中的第一列的列号 Sub test()

i = Range(\"a3:b9\").Range(\"a5\").Row 〔返回A3到B9区域的第一行第五列所在单元格位

置的真实行号〕

j = Range(\"a3:b9\").Row

i = Range(\"b3:d9\").Range(\"a5\").Column j = Range(\"b3:d9\").Column End Sub

实例：

Sub row应用()

For Each rw In Rows(\"1:13\") If rw.Row Mod 2 = 0 Then

rw.RowHeight = 5 〔将偶数行的行高设置为5，其中mod为求余函数〕 End If Next rw End Sub

10：单元格的地址与值

单元格的值表示方法 Sub 单元格值表示()

a = [a1].Value '实际是什么，就是什么 b = [a1].Text '看到是什么，就是什么 c = [a1] End Sub

'注意：一个单元格可以省略value，多单元格区域不能省略 Sub 多区域赋值()

Range(\"e1:e4\") = Range(\"d1:d4\").Value End Sub

'单元格地址与引用 Sub 地址与引用() Set rng = [b2:f2]

[a9] = rng.Address(1, 1) '绝对引用 [b9] = rng.Address(0, 0) '相对引用 [c9] = rng.Address(1, 0) '混合引用 [d9] = rng.Address(0, 1) '混合引用 End Sub

'总结：1代表固定〔绝对引用〕，0代表不固定,默认是绝对引用

Sub 地址引用实例()

'将表三成绩中为空的单元格标为未考 Dim rng As Range, rn$ On Error Resume Next

18 / 52

.

For Each rng In Sheet3.Range(\"b2:d10\")

If rng = \"\" Then rn = rn & rng.Address & \Next

Range(Left(rn, Len(rn) - 1)) = \"未考\" 〔left函数返回从左开场取字符串中, Len(rn)

– 1长度个字符〕

End Sub

11：单元格的移动与复制

'------------------------------------------------------------

'将单元格区域剪切到指定的区域

'将单元格区域复制到指定的区域 〔会复制该单元格的值和格式〕

Sub 移动复制()

Range(\"a1:d8\").Cut Range(\"f1\") Range(\"f1:i8\").Copy Range(\"a1\") End Sub

〔利用单元格赋值的方法也可以完成复制操作，在此方法中只会复制单元格的值，不会复制格式〕 Sub 另类复制方法()

Range(\"a10:d17\") = Range(\"a1:d8\").Value End Sub '注：

'2.被赋值的区域格式全部去掉

12：工作表中单元格的删除与插入

'工作表中单元格，行与列的插入与删除 Sub 插入() Rows(2).Insert End Sub

Sub 隔行插入() Dim r% Do

r = r + 2 Rows(r).Insert

Loop Until Cells(r + 1, 1) = \"\" End Sub

Sub 删除() Rows(1).Delete End Sub

Sub 隔行删除() Dim r, s

19 / 52

.

m = Application.CountA(Columns(1)) For r = 1 To m / 2 Rows(r).Delete Next End Sub

13：活动单元格与选择区域

活动单元格：activecell,工作表中活动单元格只有一个 Sub activecells()

a = activecell.Address '取得活动单元格地址 Cells(2, 3).Activate '激活指定单元格 End Sub

'selection光标所选区域 Sub 光标所选区域()

Selection = 1 〔光标所选区域的每一个单元格的值赋为1〕 End Sub

Sub 在selection中的改变活单元格() For i = 1 To Selection.Count

Selection(i).Activate 〔激活所选区域单元格〕 Next End Sub Sub 运用() Dim i As Range

For Each i In Selection

If i = \"\" Or i = \"缺勤\" Then i = \"×\" End If Next i End Sub

'小结：selection的好处在于，可以很自由灵活选择你想要处理的单元格区域

14： UsedRange已使用区域(条件统计)

'Worksheet.UsedRange 属性

'返回一个 Range 对象，该对象表示指定工作表上所使用的区域 Sub 已使用区域() End Sub '注意：

'已使用区域的定位方法是：已使用的最小单元格：最大单元格 '如果单元格中无容，但设定了格式，也认为是已使用区域 '如果没有已使用单元格，那么默认为A1单元

20 / 52

.

Sub usedrange应用()

For Each Rng In Sheet1.UsedRange

If IsNumeric(Rng) And Rng >= 90 Then k = k + 1 Next Rng

MsgBox \"大于等于90分的人数为：\" & k & \"人\" End Sub '小结：

'1.usedrange自动计算已用区域的所有值 '2.不用当数据增加时的处理问题。 '3.比selection方便，但不够灵活

15：currentregion属性

'Range.CurrentRegion 属性

'返回一个 Range 对象，该对象表示当前区域。〔返回以当前单元格说扩展后的单元格区域〕 Sub 当前区域()

[a1].CurrentRegion.Select [f8].CurrentRegion.Select End Sub

Sub currentregion应用() Rows(8).Clear

a = [b2].CurrentRegion.Address b = [b5].CurrentRegion.Address c = [b2].CurrentRegion.Count + 1 Set c = Range(\"b8\

c.FormulaArray = \"=\" & a & \"+\" & b 〔此为一数组公式，formulaArray为数组公式〕 End Sub

'usedrange与currentregion

'如果表中只有一个区域，两者最后的结果是一样的 '只是表达方式不一样 Sub u与c()

[a1].CurrentRegion.Select End Sub

16：单元格的offset〔偏移〕属性

'Range.Offset 属性

'返回 Range 对象，它代表位于指定单元格区域的一定的偏移量位置上的区域。 '表达式.Offset(偏移行, 偏移列) '表达式 一个代表 Range 对象的变量。 '偏移行列的数字可以是：正数，负数，零值

Sub test()

[a1].Offset(1, 2).Select '行列都偏移 [a1].Offset(2).Select '只偏移行

21 / 52

.

[a1].Offset(, 2).Select '只偏移列

'如果offset前面的range对象是一个区域，那么偏移后也结果尺寸不变 [a1:d1].Offset(1, 2).Select [a1:d1].Offset(2).Select [a1:d1].Offset(, 2).Select End Sub

Sub offset应用1() Dim i%

For i = 2 To 8 Step 2

[a1:e1].Copy [a1:e1].Offset(i) Next i End Sub

Sub offset应用2() Dim i%

For i = 2 To 8 Step 2 [a1:e1].Offset(i) = \"\" Next i End Sub

17：单元格的resize属性(单据数据保存)

'Range.Resize 属性

'调整指定区域的大小。返回 Range 对象，该对象代表调整后的区域。 '语法

'表达式.Resize(行数, 列数)

'表达式 一个返回 Range 对象的表达式。 Sub test()

[a1].Resize(2, 3).Select [a1].Resize(2).Select [a1].Resize(, 3).Select End Sub Sub 保存() Dim i%, j%, k%

k = Application.CountA(Sheet2.Columns(1)) [a2].Resize(i, j).Copy Sheet2.[a1].Offset(k) End Sub

18：单元格所在的行和列

'Range.EntireRow 属性

'返回一个 Range 对象，该对象表示包含指定区域的整行〔或多行〕。 '语法

'表达式.EntireRow

'表达式 一个代表 Range 对象的变量。

22 / 52

.

'Range.EntireColumn 属性

'返回一个 Range 对象，该对象表示包含指定区域的整列〔或多列〕 '语法

'表达式.EntireColumn

'表达式 一个代表 Range 对象的变量。

Sub test()

[a1].EntireRow.Select [a1].EntireColumn.Select [a1:a4].EntireRow.Select [a1:d1].EntireColumn.Select End Sub

Sub test1()

Dim rng As Range, ads As String For Each rng In [a1:a10]

If rng = \"\" Then ad = ad & rng.Address & \Next

ads = Left(ad, Len(ad) - 1) Range(ads).EntireRow.Delete End Sub

19：定位条件

'Range.SpecialCells 方法

'返回一个 Range 对象，该对象代表与指定类型和值匹配的所有单元格。 '语法

'表达式.SpecialCells(Type, Value) '表达式 一个代表 Range 对象的变量。

Sub 批注汇总()

MsgBox Application.Sum(Selection.SpecialCells(-4144)) End Sub Sub 删除空行() On Error GoTo 100

Selection.SpecialCells(xlCellTypeBlanks).Select Exit Sub 100:

MsgBox \"没有空行\" End Sub

20：find查找方法

'Range.Find 方法 '在区域中查找特定信息

23 / 52

.

'语法

'表达式.Find(What, After, LookIn, LookAt, SearchOrder, SearchDirection, MatchCase, MatchByte, SearchFormat)

'表达式 一个代表 Range 对象的变量。

Sub 查找最后一个单元格()

Set endrng = Cells.Find(\"*\Range([a1], endrng).Select End Sub

21：find查找系统 '

Sub 查询系统() ends = Columns(1).Find(\"*\动态找到A列的最后一个单元格 Range(\"g3:l999\").Clear '去除之前所有的筛选结果 For Each Rng In Range(\"a2:a\" & ends) m = m + 1 If Rng Like Range(\"h1\") Then '如果条件成立，那么 k = k + 1

Range(\"a\" & m + 1 & \":e\" & m + 1).Copy Range(\"g\" & k + 2) '将记录复制到另一

个区域

End If Next End Sub

MatchByte TRUE:区分

22：进销存之入库单

Sub 开单()

Set es = Cells.Find(\"*\a = es.Address

[b2] = \"SM\" & Format(Now(), \"ymdhms\") Range([a5], es.Offset(4)) = \"\" [e2] = \"\" End Sub

Sub 保存() On Error GoTo 100 Dim es As Range, a%

If Sheet2.[f:f].Find([b2]) = [b2] Then MsgBox \"已经保存过了!\" Else 100:

24 / 52

.

Set es = Cells.Find(\"*\ a = Application.CountA(Sheet2.[a:a]) If es.Row = 4 Then MsgBox \"没有填写容\": End Range([a5], es).Copy Sheet2.Cells(a + 1, 1)

Sheet2.Cells(a + 1, \"f\").Resize(es.Row - 4) = [b2] '保存入库单 Sheet2.Cells(a + 1, \"g\").Resize(es.Row - 4) = [e2] '保存供给商 Sheet2.Cells(a + 1, \"h\").Resize(es.Row - 4) = Now() '保存日期时间 MsgBox \"保存成功!\" End If End Sub

Sub 计算()

Set es = Columns(3).Find(\"*\For Each Rng In Range([c5], es)

Rng.Offset(0, 2) = Rng.Offset(0, 1) * Rng Next End Sub

23：单元格end属性

Sub 宏5()

Selection.End(xlDown).Select Selection.End(xlToRight).Select Selection.End(xlUp).Select Selection.End(xlToLeft).Select End Sub

Sub 分期付款最后月()

i = Cells(Rows.Count, 1).End(xlUp).Row '找到A列的最后一行的行号 Range(\"n2\将最后付款月下的区域清空 For j = 2 To i

k = Cells(j, \"n\").End(xlToLeft).Column '找到最后付款月所在的列号 Cells(j, \"n\") = Cells(1, k) '将对应的月份填入对应的单元格 Next j End Sub

24：查找最后一个单元格的N种方法

'这里讨论怎样找到最后一个单元格！

'不考虑最后量个单元格是：是公式，错误值，隐藏之类的特殊情况。 '以最后是一个常规的值为准。且以A列的最后一个单元格为准

'---------------------------------------------------------------

Sub 最后的单元格()

a = Cells(Rows.Count, 1).End(xlUp).Row 'end属性

b = Columns(1).Find(\"*\方法 c = Cells.SpecialCells(xlCellTypeLastCell).Row 'specialcells方法

25 / 52

.

f = WorksheetFunction.CountA([a:a]) '工作表函数counta g = Application.CountIf([a:a], \"<>\") '工作表函数countif End Sub

25：单元格的合并

'Application.Union 方法 '返回两个或多个区域的合并区域 '

Sub test()

Range(\"a1:b3,c5:d8\").Select '文本地址引用方式 Union([a1:b3], [c5:d8]).Select '单元格区域引用方式 End Sub

'小结：虽然range也可以完成多区域的引用 '但文本地址的引用方式最多不能超过256个字符 '而union却没有这个

'我们经常利用变量与union进展单元格的连接 Sub 连接符单元格连接() Dim rng As Range

For Each rngs In [b2:b10] adss = rngs.Address

ads = ads & rngs.Address & \Next

ad = Left(ads, Len(ads) - 1) End Sub

Sub union单元格连接()

Dim rng As Range, rngs As Range Set rng = [b2]

For Each rngs In [b2:b10] adss = rngs.Address Set rng = Union(rng, rngs) ads = rng.Address Next End Sub

26：单元格的交集

'Application.Intersect 方法

'返回一个 Range 对象，该对象表示两个或多个区域重叠的矩形区域。 Sub test()

If Intersect([a1:d10], Selection) Is Nothing Then '注释：Is Nothing 用于判断对象是

否存在，对象可以是工作簿，工作表，单元格区域等

MsgBox \"没有交集\"

26 / 52

.

Else

MsgBox Intersect([a1:d10], Selection).Address Intersect([a1:d10], Selection).Select End If End Sub

Sub 隔行插入()

For i = 0 To Application.CountA(Columns(1)) * 2 Step 2

Intersect([a1:d2].Offset(i), [a2:d3].Offset(i)).EntireRow.Insert Next End Sub

27：单元格数字格式的设置代码

'Range.NumberFormatLocal 属性 Sub 获取单元格设置数字格式() For Each Rng In [a1:a3]

Cells(Rng.Row, 2) = Rng.NumberFormatLocal '获取单元格的格式代码 Next Rng End Sub

Sub 给单元格设置数字格式() For Each Rng In [a1:a3]

Rng.NumberFormatLocal = \"0.00\" Next Rng End Sub

Sub 保存1111()

Set es = Cells.Find(\"*\a = Application.CountA(Worksheets(\"记录保存\").[a:a]) Range([a5], es).Copy Worksheets(\"记录保存\").Cells(a + 1, 1) With Worksheets(\"记录保存\")

.Cells(a + 1, \"f\").Resize(es.Row - 4) = [b2] '保存入库单 .Cells(a + 1, \"g\").Resize(es.Row - 4) = [e2] '保存供给商 .Cells(a + 1, \"h\").Resize(es.Row - 4) = Now() '保存日期时间

.Cells(a + 1, \"h\").Resize(es.Row - 4).NumberFormatLocal = \"e-m-d aaaa\" End With

MsgBox \"保存成功!\" End Sub

28：单元格字体格式设置代码实现

'Font 对象

'包含对象的字体属性〔字体名称、字号、颜色等等〕。

27 / 52

.

'Range.ClearFormats 方法 '去除对象的格式设置

'常见font对象的属性 Sub font对象属性() With [a2:a6].Font

.Name = \"微软雅黑\" '字体 .Size = 8 '字号 .Bold = True '加粗

.Color = RGB(255, 0, 255) '颜色 End With End Sub

Sub 大于90分的颜色设置为红色() Set i = Cells(Rows.Count, 3).End(xlUp) Range([b2], i).ClearFormats For Each Rng In Range([b2], i) If Rng.Value >= [f1] Then With Rng.Font

.Name = \"华文琥珀\" .Size = 20 .Bold = True

.Color = RGB(255, 0, 0) End With End If Next Rng End Sub

29：底纹颜色的设置

'Interior 对象 '代表一个对象的部

'针对interior对象，我们用得最多的是它的颜色，下面就来讨论一下。

Sub 索引颜色值() For i = 1 To 56

Cells(i, 1).Interior.ColorIndex = i Cells(i, 2) = i Next i End Sub

Sub 早期颜色值() For i = 0 To 15

28 / 52

.

Cells(i + 1, 1).Interior.Color = QBColor(i) Cells(i + 1, 2) = i Next i End Sub

Sub 三原色颜色值()

Cells(2, 4).Interior.Color = RGB([a1], [b1], [c1]) End Sub

Sub 直接颜色值() '此颜色有255^3种颜色 Cells(1, 1).Interior.Color = [b1] End Sub

30：单元格格式设置实例

Sub 格式化工资条() Dim i%

i = Cells(Rows.Count, 1).End(xlUp).Row For j = 1 To i If j Mod 2 Then

With Cells(j, 1).EntireRow.Range(\"a1:g1\").Font .Bold = True .Size = 8 .ColorIndex = 56 End With Else

With Cells(j, 1).EntireRow.Range(\"a1:g1\").Interior “以本行第一个单元格为

坐标的A1：G1〞区域

.ColorIndex = 40 End With End If Next j End Sub

Sub 去除格式化() Selection.ClearFormats End Sub

31：利用查找颜色功能拾取颜色求平均

Sub 根据查找功能拾取的颜色求平均() On Error GoTo 100

Dim erng As Range, rng As Range, i As Long

Set erng = Cells(Rows.Count, \"e\").End(xlUp) For Each rng In Range([b2], erng)

29 / 52

.

Next

MsgBox \"最后平均分为：\" & k / n & \"分\" End 100:

MsgBox \"查找功能没有拾取到颜色！\" End Sub

32：粘贴

Option Explicit 'Worksheet.Paste 方法

'将“剪贴板〞中的容粘贴到工作表上。 '表达式.Paste(Destination, Link)

'表达式 一个代表 Worksheet 对象的变量。

Sub 粘贴()

Range(\"B1:B6\").Copy Range(\"c9\") Range(\"B1:B6\").Copy '复制区域无公式 Sheet1.Paste Range(\"c9\") '粘贴到c4单元格 End Sub

Sub 粘贴2()

Range(\"c1:c6\").Copy '复制单元格有公式

Sheet3.Paste '如果不指定 Destination 参数，那么在使用该方法之前必须选择目标区域。 End Sub

Sub 粘贴1()

Range(\"c1:C6\").Copy '复制c1单元格 Sheet3.Paste , True '

Application.CutCopyMode = True End Sub

33：选择性粘贴

Option Explicit

'Range.PasteSpecial 方法

'将 Range 从剪贴板粘贴到指定的区域中。 '语法

'表达式.PasteSpecial(Paste, Operation, SkipBlanks, Transpose) '表达式 一个代表 Range 对象的变量。

30 / 52

.

Sub 选择怪粘贴() Range(\"c2:c10\").Copy Range(\"d2\").PasteSpecial 12 End Sub

Sub 选择怪粘贴运算() Range(\"b2:b9\").Copy

Range(\"d2\").PasteSpecial , 2 Range(\"c2:c9\").Copy

Range(\"d2\").PasteSpecial , 2 End Sub

Sub 选择怪粘贴跳过空单元() Range(\"b2:b9\").Copy

Range(\"e2\").PasteSpecial , , True End Sub

Sub 选择性粘贴转置() Range(\"a2:b9\").Copy

Range(\"a11\").PasteSpecial 12, , , True End Sub

31 / 52

.

34：合并单元格

Option Explicit 'Range.Merge 方法

'由指定的 Range 对象创立合并单元格。

Sub 合并单元格() Selection.Merge End Sub

Sub 合并单元格实例() Dim er%, rng%, rg As Range Application.DisplayAlerts = False er = Application.CountA([a:a]) For rng = er To 2 Step -1 Set rg = Range(\"a\" & rng)

If rg = rg.Offset(-1) Then rg.Offset(-1).Resize(2).Merge Next

Application.DisplayAlerts = True End Sub

35：合并单元格实例与取消合并单元格

'----------------------------------------------------------------------- 'Range.MergeArea 属性

'返回一个 Range 对象，该对象代表包含指定单元格的合并区域。

'Range.UnMerge 方法

'将合并区域分解为的单元格

'-------------------------------------------------------------------------- Sub test()

a = Range(\"a1\").MergeArea.Count [a1].UnMerge End Sub

Sub 解除合并单元格后保持原来的数据() Dim b%, rng As Range

For Each rng In Selection

32 / 52

.

rng.UnMerge

rng.Resize(b) = rng Next End Sub

36：有条件的添加批注

'Comment 对象 '代表单元格批注

'批注添加

Sub 批注添加() With [a1]

If .Comment Is Nothing Then .AddComment.Text \"123\" .Comment.Visible = True End If End With End Sub

Sub 删除批注()

For Each Rng In Selection

If Not Rng.Comment Is Nothing Then Rng.ClearComments End If Next End Sub

Sub 批量添加批注()

For Each Rng In Range(\"a2:a20\") Rng.ClearComments Next End Sub

37：修改批注〔注意文件地址的书写方式〕

'修改批注 Sub 修改批注()

Range(\"a2\").AddComment '添加批注 End Sub

33 / 52

.

Sub 批量将批注增加背景() For Each Rng In Selection

paths = ThisWorkbook.Path & \"\\7pic\\\" & Rng.Value & \".png\" Rng.ClearComments Rng.AddComment Next End Sub

38：图形根底

'Shapes 对象

'指定的工作表上的所有 Shape 对象的集合。 '说明

'每个 Shape 对象都代表绘图层中的一个对象，如自选图形、任意多边形、图片、图表等。

Sub abc() Dim ob As Shape

For Each ob In Sheet1.Shapes k = k + 1 ob.Select

Cells(k + 1, \"f\") = ob.Name '图形名称 Cells(k + 1, \"g\") = ob.Type '图形类型 Cells(k + 1, \"h\") = ob.Top '顶端坐标 Cells(k + 1, \"i\") = ob.Left '左端坐标 Cells(k + 1, \"j\") = ob.Width '宽度 Cells(k + 1, \"k\") = ob.Height '高度 Next ob End Sub

Sub 图形插入()

True, True, 100, 100, 70, 70 End Sub

Sub 图形删除()

For Each shp In Sheet3.Shapes shp.Delete Next shp End Sub

39：图形的插入应用实例

34 / 52

.

Sub 宏1()

For Each shap In Sheet1.Shapes If shap.Type <> 8 Then shap.Delete Next shap

For Each Rng In Range([a2], Cells(Application.CountA(Columns(1)), 1)) i = ThisWorkbook.Path & \"\\7pic\\\" & Rng & \".png\" Set rngs = Cells(Rng.Row, 2) Next Rng End Sub

40：多表合并

'Option Explicit

Sub 多表合并()

Dim i%, rs%, rss%, st As Worksheet, zst As Worksheet

Set zst = Sheets(\"1季度\") '将汇总工作表\"1季度\"定义为变量zst For i = 1 To 3

Set st = Sheets(i & \"月\") '将1-3每月的工作表定义为变量st

“1季度的最后一行的下一行〞

st.Range(\"a2:b\" & rs).Copy zst.Cells(rss, 1) '复制1-3表的数据到总表中 zst.Cells(rss, 3).Resize(rs - 1) = i & \"月\" '将1-3表的工作表名写入到总表对应的

记录中

Next End Sub

41：多表拆分

Sub 多表拆分()

For f = 1 To 3 '循环三次〔只拆分三个月〕

For Each Rng In Sheets(\"总表\").Range(\"a2:a15\")

If Rng.Value = f & \"月\" Then '如果a列的值等于当前的月份 n = \"a\" & Rng.Row & \":d\" & Rng.Row '构造被复制的源表区域 y = y + 1 '新表行数累计 If y = 1 Then

Sheets(\"总表\").Range(\"a1:d1\").Copy Sheets(f & \"月\").Cells(y, 1) End If

Sheets(\"总表\").Range(n).Copy Sheets(f & \"月\").Cells(y + 1, 1) '那么

将当前月份所在行复制到新建月份表中

End If Next

y = 0 '分表行数累计归零 Next End Sub

35 / 52

.

第四章：事件程序:

1：事件程序定义与作用

'1.定义

'excel事件程序：因为一个操作(动作)而触发了一段程序。让程序发生了运行。 '就像机关设置 '2.实例

'例1：翻开工作表1，那么运行一段程序〔选择工作表1触发程序〕 '例2：保护工作表数据实例。 '3.作用

'excel事件程序的作用：以前程序只能通过手工运行或指定宏功能来完成 '事件程序那么可以却因不同的操作而自动触发运行不同的程序。

'4.代码位置

'excel事件程序代码存放在位置 '----------------------------------- '事件类型 代码位置

'----------------------------------- '工作表事件 工作表

'工作簿事件 工作簿(thisworkbook)

'程序事件 工作簿(thisworkbook)或类模块

2：事件程序根底

'代码存储位置

'事件 代码位置 '-------------------------------------------------------

'应用程序-根据应用程序的动作进展控制 类模块或thisworkbook 对所有工作簿操作的

相关事件

'工作簿-根据工作簿的动作进展控制 thisworkbook 对所有工作表操作的

相关事件

'工作表-根据工作表的动作进展控制 sheet1.sheet2.... 对工作表中所有单元

操作的相关事件

36 / 52

.

'2.括号里面是参数(传回值用法)

'target:传递单元格对象〔例子：禁止选择〕

'sh:传递工作表对象〔例子：新建工作表时提示更改名称〕

'3.代码保护

'方法:工具-VBAProject属性-保护

应用程序事件 NewWorkbook SheetActivate

SheetBeforeDoubleClick SheetBeforeRightClick SheetCalculate SheetChange SheetDeactivate SheetFollowHyperlink SheetPivotTableUpdate SheetSelectionChange WindowActivate WindowDeactivate WindowResize WorkbookActivate WorkbookAddinInstall WorkbookAddinUninstall WorkbookAfterXmlEmport WorkbookAfterXmlImport WorkbookBeforeClose WorkbookBeforePrint WorkbookBeforeSave WorkbookBeforeXmlExport WorkbookBeforeXmlImport WorkbookDeactivate WorkbookNewSheet WorkbookOpen

注释

当新建一个工作簿时发生此事件 当激活任何工作表时发生此事件 在双击任何工作表前发生此事件 右键单击任何工作表前发生此事件 在重新计算工作表时发生此事件 更改任何工作表的单元格时发生此事件

当工作表失去焦点时发生此事件〔离开工作表时〕。 在单击工作簿中的任何超时发生。 在更新数据透视表的工作表后发生。 所选容在任何工作表上更改时发生。 在激活任何工作簿窗口时发生。

工作簿的窗口变为非活动状态时，将产生本领件。 改变工作簿窗口大小时发生 当激活任何工作簿时发生此事件 工作簿为加载宏安装时发生此事件 当任一工作簿作为卸载宏时发生

在保存或导出工作簿中的XML数据之后发生此事件

当刷新现有的XML数据或新的XML数据被导入任一翻开的Excel工作簿之后时发生关闭任何工作簿前发生此事件 在打印工作簿前发生此事件 在保存任何工作簿前发生引事件 保存或导出XML数据前发生的事件

当刷新现有的XML数据或新的XML数据被导入任一翻开的Excel工作簿之前时发生当翻开的工作簿转为非活动状态时发生此事件 在任何翻开的工作簿中新建工作表时发生此事件 当翻开一个工作簿时发生此事件

WorkbookPivotTableCloseCloseConnection 在数据透视表的关闭之后发生此事件 WorkbookPivotTableOpenCloseConnection WorkbookRowsetCompletd Workbooksync

在数据透视表的翻开之后发生此事件

如果用户在OLAP数据透视表上深化记录集或调用行集操作，那么会发生WorkbookRowsetComplete事件 此事件

当作为“文档工作区〞一局部的工作簿的本地副本与效劳器上的副本进展同步时发

37 / 52

. 工作簿事件 Activate AddinInstall AddinUninstall AfterXmlExport AfterXmlImport BeforeClose BeforePrint BeforeSave BeforeXmlExport BeforeXmlImport Deactivate NewSheet Open

PivotTableCloseConnection PivotTableOpenConnection RowsetComplete SheetActivate

SheetBeforeDoubleClick SheetBeforeRightClick SheetCalculate SheetChange SheetDeactivate SheetFollowHyperlink SheetPivotTableUpdate SheetSelectionChange Sync

WindowActivate WindowDeactivate WindowResize 工作表事件 Activate

BeforeDoubleClick BeforeRightClick Calculate Change Deactivate FollowHyperlink

注释

激活工作簿、工作表、图表工作表或嵌入式图表时发生此事件 当工作簿作为加载宏安装时，发生此事件 当工作簿作为加载宏卸载时，发生此事件

在Excel保存或导出指定工作簿中的XML数据之后发生此事件

在刷新现有的XML数据或将新的XML数据导入到指定的Excel工作簿之后，发生此件

户是否保存更改之前产生。

在打印指定工作簿〔或者其中的任何容〕之前，发生此事件 保存工作簿之前发生此事件

在Excel保存或导出指定工作簿中的XML数据之后发生此事件

在关闭工作簿之前，先产生此事件。如果该工作簿已经更改正，那么本领件在询问

在刷新现有的XML数据或将新的XML数据导入到指定的Excel工作簿之后，发生此件

图表、工作表或工作簿被停用时发生此事件 当在工作簿中新建工作表时发生此事件 翻开工作簿时，发生此事件

数据透视表关闭与其数据源的后发生此事件 数据透视表翻开与其数据源的后发生此事件

如果用户在OLAP数据透视表上深化记录集或调用行集操作，那么会引发此事件 当激活任何工作表时发生 此事件

当双击任何工作表时发生此事件，此事件先于默认的双击操作发生 右键单击任一工作表时发生此事件，此事件先于默认的右键单击操作 在重新计算工作表时或在图表上绘制更改的数据之生发生此事件 当用户或外部更改了任何工作表中的单元格时发生此事件 当任何工作表停用时发生此事件 单击Excel中的任何超时发生此事件 在数据透视表的工作表更新之后发生此事件 任一工作表的选定区域发生更改时，将发生此事件

当作为“文档工作区〞一局部的工作表的本地副本与效劳器上的副本进展同步时，生此事件

工作簿窗口被停用时发生此事件 任何工作簿窗口调整大小时发生此事件 任何工作簿窗口被停用时发生此事件 注释

激活工作簿，工作表，图表等发生的事件 在工作表中双击前发生的事件 右键单击工作表前发生的事件 工作表重新计算之后发生的事件 更改工作表中的单元格发生的事件

工作表，图表停用〔焦点离开〕时发生的事件 单击工作表上的任意超时，发生此事件

38 / 52

. PivotTableUpdate SelectionChange

工作簿中的数据透视表更新后发生此事件 当工作表上选定区域发生改变时发生此事件

3：工作表事件实例1〔自选计算与投票统计〕

Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim rs

rs = Application.CountA(Columns(1))

If Target.Address = Range(\"a1:a\" & rs).Address Then For i = 1 To rs

Cells(i, 2) = \"=\" & Cells(i, 1) Next End If

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range) On Error Resume Next

If Target.Address = \"$A$3\" Or Target.Address = \"$B$3\" _ Or Target.Address = \"$C$3\" Or Target.Address = \"$D$3\" Then Target.Value = Target.Value + 1 End If

End Sub

4工作表事件实例2

'中选择的单元格地址显示在状态栏上方法一

Private Sub Worksheet_SelectionChange(ByVal Target As Range) Application.StatusBar = \"当前选择的区域是：\" & Target.Address(0, 0) End Sub

Private Sub Worksheet_Deactivate() Application.StatusBar = \"\"

End Sub

'中选择的单元格地址显示在状态栏上方法一

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Application.StatusBar = \"当前选择的区域是：\" & Selection.Address(0, 0) End Sub

Private Sub Worksheet_Deactivate()

Application.StatusBar = \"当前选择的区域是：\"

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Sheet3.Name <> \"成绩表\" Then Sheet3.Name = \"成绩表\"

End Sub

5：工作表事件实例〔自动列出工作表名与单元格区域保护〕

39 / 52

.

Private Sub Worksheet_Activate() For Each sht In Sheets

If sht.Name <> \"全年月份\" Then k = k + 1

Sheets(\"全年月份\").Cells(k, 1) = sht.Name End If Next End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Intersect(Target, [a1:c12]) Is Nothing Then MsgBox \"你只能在[a1:c12]区域中工作！\" [a1].Select End If

End Sub

6：工作簿事件实例1〔自动选择月份表、右键禁用、打印控制〕

'事件中的Cancel:

' 默认为false，在完成事件代码效果后，接着继续完成操作的后续效果。 ' 而为true时，在完成事件代码效果后，终止当前操作的后续效果。

' 相当于给用户控制事件提供一个开关。可以把用户自定义事件代替默认事件 ' 没有Cancel就是说不给你这个控制权限，一旦一始就要按流程完毕。

Private Sub Workbook_Open() mon = Format(Now(), \"m\") Sheets(mon & \"月\").Select End Sub

Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range,

Cancel As Boolean)

Cancel = True '禁用右键 End Sub

Private Sub Workbook_BeforePrint(Cancel As Boolean) If Month(Now()) & \"月\" <> ActiveSheet.Name Then MsgBox \"不能打印\" Cancel = True Else

MsgBox \"能打印\"

40 / 52

.

Cancel = False End If End Sub

7：工作簿事件实例2〔给工作表加密码〕

'Application.EnableEvents 属性

'Application.EnableEvents = True/FALSE

'如果对指定对象启用事件，那么该属性值为 True。Boolean 类型，可读写。 '作用：临时关闭，防止死循环 'Private Sub Workbook_Open() 'Application.EnableEvents = True

'Sheet3.Activate 'End Sub

Private Sub Worksheet_Activate() '激活工作表触发的程序 a = InputBox(\"请输入密码\") If a = 123 Then

Application.EnableEvents = False Else

Sheet3.Activate End If End Sub

8：应用程序事件

'应用程序事件：是对每个翻开工作簿操因操作所发生的事件程序 '应用程序事件代码位置：thisworkbook或者类模块 '应用程序事件代码在thisworkbook中的存在的先决条件

' 1.申明变量

' Public WithEvents app As Excel.Application

' 2.工作簿翻开时运行

' Private Sub Workbook_Open() ' Set app = Excel.Application ' End Sub

' 3.将1、2点的代码写在thisworkbook中,并保存为“加载宏〞文件〔xla,xlam〕

' 4.在加载宏菜单中加载第三步保存的加载宏文件。 ' 目的：任何时候都能依附在excel文件中。

' 例子：任何时候都不能增加工作表

9：应用程序事件实例

Private Sub excelapp_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

41 / 52

. '4-8课容

Application.StatusBar = \"选择区域是：\" & Target.Address(0, 0) '任意工作表显示选择区

域地址

End Sub

Private Sub excelapp_NewWorkbook(ByVal Wb As Workbook) Application.Dialogs(5).Show '强制新建就保存 End Sub

Private Sub excelapp_WorkbookBeforePrint(ByVal Wb As Workbook, Cancel As Boolean) '4-8

课容

a = InputBox(\"请输入打印密码\") '打印机要求输入打印密码 If a = 123 Then Cancel = False Else

Cancel = True

MsgBox \"对不起，密码不正确，你不能打印！\" End If End Sub

10：事件总结

1.各种事件的作用围

工作表：作用于某个工作表下的所有单元格操作 工作簿：作用于某个工作簿下的所有工作表 应用程序:作用于所有工作簿。

2.各种事件过程代码的执行顺序 工作表事件→工作薄事件→应用程序事件

42 / 52

.

第五章：VBA数组

1：数组根底

' 1.数组概念

' 数组就是一个列表或者一组数据表. '

' 2.数组位置 ' 数组存储在存中. '

' 3.数组特点

' a.读写速度快〔从存读取数据要比从硬盘读取快〕 ' b.无法永远保存(存只是暂存空间)

' 4.数组分类

' a.一般分为：常量数组，静态数组，动态数组 ' b.如按维度为：1维，2维，3维......60 维 '

' 5.当我们学会了数组，会发现以前的写的很多代码可以从数组的角度重写 '

Sub test2() Dim arr1(3) Dim arr2(1 To 3) Dim arr3(1 To 3, 1 To 2) Dim arr4(3, 2) End Sub

2：数组维度

' 数组最多有60维，但在excel中一般最到2维 ' 1.excel中的一行或一列可以转换1维数组 ' 2.excel中的多行多列可以转换成2维数组 '

Sub test1()

arr1 = [{\"A\

arr2 = Application.Transpose([{1;2;3;4}]) 【转置】 End Sub

Sub test2()

arr3 = [{\"\王\林\End Sub

43 / 52

.

Sub test4()

arr = Array(1, 2, 3, 4)

arr1 = Array(Array(\"a\

End Sub

3向数组中写数据

Sub 循环向数组中写入数据() Dim arr(1 To 4) For Each Rng In [a1:a4] n = n + 1 arr(n) = Rng Next End Sub

Sub 常量数组数据写入一般数组() Dim arr()

arr = Array(\"V\End Sub

Sub 单元格区域数据批量写入数组()

arr = Application.Transpose([a1:a4]) '注意：当向数组中批量写入多行，结果就是二维数

组

arr1 = Application.Transpose(Application.Transpose([a7:d7]))

End Sub

4:在数组中取数据

'怎样在数组中取数

Sub 取数组中指定位置的元素() arr = [a2:a5] MsgBox arr(2, 1) MsgBox arr(4, 1) End Sub

Sub 方法1循环取数() arr = [a2:a9] [b1] = arr(2, 1) For i = 1 To 8

Cells(i, 3) = arr(i, 1) Next End Sub

Sub 方法2一次性取数() arr = [a2:a5]

Range(\"d1:d\" & 4) = arr End Sub

Sub 用transpose函数转置() arr = [a2:a5]

44 / 52

.

arr1 = Application.Transpose(arr) [a7:d7] = arr1 [a8:c8] = arr1 [a9:e9] = arr1

'注意左右两边尺寸的对应 【赋值时候是从左向右】 End Sub

5：数组运用〔数据汇总〕

'在数组中求和，平均，最大，最小，极大，极小值等 Sub test() arr = [b2:c9]

'MsgBox WorksheetFunction.Sum(arr) 'MsgBox WorksheetFunction.Average(arr) 'MsgBox WorksheetFunction.Max(arr) 'MsgBox WorksheetFunction.Min(arr) 'MsgBox WorksheetFunction.Small(arr, 2) MsgBox WorksheetFunction.Large(arr, 2) End Sub

Sub test2() Dim arr1(1 To 99) arr = [b2:c9] For Each a In arr If a >= 80 Then n = n + 1 arr1(n) = a End If Next

MsgBox WorksheetFunction.Average(arr1)

End Sub

6：数组写入与读取实例(数组的优势表达)

'比比哪个程序的运行速度更快

Sub 方法一() t = Timer

Set Rng = Cells(Rows.Count, 1).End(xlUp) arr = Range([a1], Rng)

For Each a In Range([a1], Rng)

If a >= 90 Then n = n + 1: Cells(n, 3) = a Next

MsgBox Format(Timer - t, \"0.0000\") End Sub

Sub 方法二() t = Timer

45 / 52

.

Dim arr1(1 To 5000, 1 To 1)

Set Rng = Cells(Rows.Count, 1).End(xlUp) arr = Range([a1], Rng) '数组写入 For Each a In arr If a >= 90 Then n = n + 1

arr1(n, 1) = a '将arr数组中的数据有条件的将数据写入arr1数组 End If Next

[d1].Resize(n) = arr1

MsgBox Format(Timer - t, \"0.0000\") End Sub

7：数组应用之计算不重复值

'UBound 函数

'UBound(arrayname[, dimension])

'返回一个 Long 型数据，其值为指定的数组维可用的最大下标。

Sub test()

Dim arr(4 To 8, 1 To 3, 1 To 9)

MsgBox UBound(arr) '可简写为：UBound(arr〕 MsgBox UBound(arr, 2) MsgBox UBound(arr, 3)

MsgBox LBound(arr) 'LBound 用来确定数组某一维的上界。 End Sub

Sub 利用数组提取不重复值() Dim arr1(1 To 10)

Set lastcell = Cells(Rows.Count, \"b\").End(xlUp) '查找最后B列最后一个非空单元格 arr = Range([b2], lastcell) '将B列的数据赋值给变量arr形成一个数组 For i = 1 To lastcell.Row - 1 '循环B列单元格个数的次数

For j = 1 To UBound(arr1) '找到arr1数组的最大小标，形成循环 x = arr(i, 1): y = arr1(j) '辅助代码 If arr(i, 1) = arr1(j) Then

GoTo 100 'arr数组元素与arr1元素循环比照，如果相等，那么跳出层循环 End If Next j

k = k + 1 '做个计数器，计算相等重复的元素人数

arr1(k) = arr(i, 1) '如果循环完后都没有相等的，那么将arr1循环的元素赋值给

arr1数组

100: Next i

[e2].Resize(k) = Application.Transpose(arr1) '循环完毕后将arr1的结果赋值给单元

格区域

46 / 52

. End Sub

8：数组运用(分类求和)

Sub 利用数组提取不重复值() Dim arr1(1 To 10, 1 To 2)

Set endr = Cells(Rows.Count, \"c\").End(xlUp) '查找最后B列最后一个非空单元格 arr = Range([b2], endr) '将B列的数据赋值给变量arr形成一个数组 For i = 1 To endr.Row - 1 '循环B列单元格个数的次数

For j = 1 To UBound(arr1) '找到arr1数组的最大小标，形成循环 x = arr(i, 1): y = arr1(j, 1) '辅助代码 If arr(i, 1) = arr1(j, 1) Then

arr1(j, 2) = arr(i, 2) + arr1(j, 2)

GoTo 100 'arr数组元素与arr1元素循环比照，如果相等，那么跳出层循环 End If Next j

k = k + 1 '做个计数器，计算相等重复的元素人数

arr1(k, 1) = arr(i, 1) '如果循环完后都没有相等的，那么将arr1循环的元素赋值

给arr1数组

arr1(k, 2) = arr(i, 2) 100: Next i

[e2].Resize(k, 2) = arr1 '循环完毕后将arr1的结果赋值给单元格区域 End Sub

9：动态数组〔条件筛选〕

'dim 'ReDim 语句

'在过程级别中使用，用于为动态数组变量重新分配存储空间。 'ReDim [Preserve] varname( ) [As type]

'可以使用 ReDim 语句反复地改变数组的元素以及维数的数目，

'有redim之后可以确定数组的上界，而不用估计一个值 Sub test3() Dim arr(), arr1()

rn = Cells(Rows.Count, 1).End(xlUp).Address 【定位最后一行】 arr1 = Range(\"a2\

m = WorksheetFunction.CountIf(Range(\"a2\确定重新定义数组的上界【工

作表函数】

ReDim arr(1 To m) For Each ar In arr1 If ar >= 80 Then n = n + 1 arr(n) = ar End If Next

[c2].Resize(UBound(arr)) = Application.Transpose(arr)

47 / 52

. End Sub

10：动态数组(多表合并)

'Preserve 可选的。关键字，当改变原有数组最末维的大小时，使用此关键字可以保持数组中

原来的数据。

Sub abc() Dim arr() i = 9

arr = [{1,2,3}]

ReDim Preserve arr(1 To 5) ReDim Preserve arr(1 To i) End Sub

Sub 数组多表合并() Dim arr()

For Each sh In Sheets

If sh.Name <> \"汇总\" Then '目的：只有\"汇总\"工作表的数据不合并

act = act + UBound(arr1) '累加各表数据的行数，作为重新声明arr1数组的上

界

ReDim Preserve arr(1 To 2, 1 To act) '重新声明数组arr 【变量只能放在最后面，改变最后一个维度】

For j = 1 To UBound(arr1) '准备将各表的数据循环写入重新声明的arr数组中 n = n + 1 '每条件即将要写入arr数组的记录数累加

arr(1, n) = arr1(j, 1) 'arr1对应写入arr中，此写入的方法需要在单元格中

演示一下

arr(2, n) = arr1(j, 2) 'arr1对应写入arr中 Next End If Next

Sheets(\"汇总\").[a2].Resize(n, 2) = Application.Transpose(arr) '将arr中的数据批量写

入单元格 End Sub

11： Split函数与数组〔字符串生成数组〕

'Split函数(作用于1维数组)

'返回一个下标从零开场的一维数组，它包含指定数目的子字符串。

'Split(字符串,\"分隔符\") Sub test() Dim i$

i = \"a-b-c-d-e-f\" arr = Split(i, \"-\")

[a1].Resize(1, UBound(arr)) = arr End Sub

48 / 52

.

Sub 数据互换()

arr = [a1].CurrentRegion 【以A1单元格为扩展的单元格】 For Each a In arr arr1 = Split(a, \"-\") n = n + 1

Cells(n, \"c\") = arr1(1) & \"-\" & arr1(0) Next End Sub

12： Join函数与数组〔数组生成字符串〕

'Join函数(作用于1维数组)

'返回一个字符串，该字符串是通过连接某个数组中的多个子字符串而创立的。

'Join(数组,\"连接符\")

Sub test() arr = [{1,2,3,4}] i = Join(arr, \"-\") End Sub

Sub 数据合并()

i = Sheet3.Cells(Rows.Count, 1).End(xlUp).Row 【寻找最后一行】 With Sheet3 For j = 1 To i

Set k = Range(.Cells(j, 1), .Cells(j, Columns.Count).End(xlToLeft)) 【寻找一行

最后一个非空单元格，返回一个range对象】

arr = Application.Transpose(Application.Transpose(k)) 【k为一个4列的二维数组，

转置两次后变为一个一维数组】

Cells(j, 1) = \"'\" & Join(arr, \"\") 【前添加逗号，默认的返回一个字符串，否那么会

以字符串表示，超过12位就会以科学计数法表示】

Next j End With End Sub

13： Fileter函数与数组〔巧用Filter实现多列结果〕

'Filter函数(作用于1维数组)

'返回一个下标从零开场的数组，该数组\"包含\"基于指定筛选条件的一个字符串数组的子集。 '语法

'Filter(要搜索的1维数组。, 搜索的字符串,[TRUE/FALSE]) Sub test()

arr = [{\"abc\

49 / 52

.

a = Filter(arr, \"b\b = Filter(arr, \"b\End Sub

Sub 筛选() [d2:f999].Clear

i = Cells(Rows.Count, 1).End(xlUp).Row

Range(\"c2:c\" & i).FormulaArray = \"=a2:a\" & i & \" & \"\"-\"\" & b2:b\" & i arr = Range(\"c2:c1\" & i) Range(\"c2:c1\" & i).Clear

a = Filter(Application.Transpose(arr), [g1], True) For Each b In a n = n + 1 c = Split(b, \"-\") Cells(n + 1, \"d\") = c(0) Cells(n + 1, \"e\") = c(1) Next End Sub

14：工作表函数与VBA数组(几句代码制作查询系统)

'在工作表支持数组的函数，很多也支持VBA数组 '返回结果，当然也是一个数组

'如sumif,countif,match,index,vlookup.....

'工作表函数INDEX处理VBA数组

'如对INDEX函数不了解：请移驾自学网：.51zxw.net/list.aspx?page=6&cid=366 '观看(5-7a)-(5-7f)节，！

'index工作表函数可以对VBA二维数组进展1行或1列的截取 Sub test() arr = [a2:g13]

arr1 = WorksheetFunction.Index(arr, 0, 2) arr2 = WorksheetFunction.Index(arr, 3, 0) End Sub

Sub 查询系统() [i3:o999].Clear

arr = Range(\"a2\For i = 1 To UBound(arr) If arr(i, 1) Like [j1] Then n = n + 1

Cells(n + 2, \"i\").Resize(1, 7) = WorksheetFunction.Index(arr, i, 0)

50 / 52

.

End If Next

End Sub

15:借助VBA数组快速格式化单元格

Sub VBA数组格式化单元格() Cells.ClearFormats

arr = Range(\"g2:g\" & Cells(Rows.Count, \"g\").End(xlUp).Row) For i = 1 To UBound(arr) If arr(i, 1) >= 330 Then

Set Rng = Cells(i + 1, \"g\").EntireRow.Range(\"a1:g1\") n = n + 1

If n = 1 Then Set rngs = Rng Else Set rngs = Union(rngs, Rng) k = rngs.Address End If Next End Sub

16:利用VBA数组进展排序

Sub 排序() arr = Selection

For i = 1 To UBound(arr)

For j = i + 1 To UBound(arr) If arr(i, 1) > arr(j, 1) Then k = arr(i, 1)

arr(i, 1) = arr(j, 1) arr(j, 1) = k End If Next Next

[b1].Resize(UBound(arr)) = arr End Sub

17: VBA数组分类汇总

Sub VBA数组分类汇总() Dim arr1() arr = [a2:c13]

For i = 1 To UBound(arr)

ReDim Preserve arr1(1 To 2, 1 To n + 1) For j = 1 To UBound(arr1, 2) If arr1(1, j) = arr(i, 1) Then

arr1(2, j) = arr1(2, j) + arr(i, 3) GoTo 100 End If Next

n = n + 1

51 / 52

.

arr1(1, n) = arr(i, 1) arr1(2, n) = arr(i, 3) 100: Next

[e2].Resize(n, 2) = Application.Transpose(arr1)

End Sub

第六章：

VBA与字典技术52 / 52