VBA中用单元格被单击单击事件来模拟超级链接的效果
点击联系发帖人
时间：2018-08-03 18:39
(window.slotbydup=window.slotbydup || []).push({
id: '3284507',
container: s,
size: '0,0',
display: 'inlay-fix'
excel用VBA选择工作表中所有包含超链接的单元格
要选择工作表中所有包含超链接的单元格，用定位或查找的方法无法实现。下面的VBA代码可以实现这一目的。
按Alt+F11，打开VBA编辑器，在&工程&窗口中双击某个工作表，在右侧的代码窗口中输入下列代码：
Sub SelectHyperlinkCells()
Dim hHlink As Hyperlink
Dim rRange As Range
Dim NotFirstlink As Boolean
On Error Resume Next
For Each hHlink In ActiveSheet.Hyperlinks
If NotFirstlink Then
Set rRange = Application.Union(rRange, hHlink.Range)
Set rRange = hHlink.Range
NotFirstlink = True
If rRange Is Nothing Then End
rRange.Select
关闭VBA编辑器返回工作表界面，按Alt+F8打开&宏&对话框，运行&SelectHyperlinkCells&宏即可选择工作表中所有包含超链接的单元格。
标签(Tag):
------分隔线----------------------------
------分隔线----------------------------
猜你感兴趣查看: 20843|回复: 13
VBA 单击单元格触发事件
阅读权限20
在线时间 小时
请大侠们帮忙
如何在单击某个区域的单元格时判断该单元是否为空
如果为空输入指定数值
如果不为空则输入空值
阅读权限95
在线时间 小时
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Value = && Then
& & Target.Value = 1
Else
& & Target.Value = &&
End If
End Sub
复制代码
阅读权限20
在线时间 小时
& & & & & & & &
dsmch 发表于
还有点小问题 我只要某个区域的单元格单击触发
阅读权限95
在线时间 小时
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Application.Intersect([a1:c10], Target) Is Nothing Then
& & If Target.Value = && Then
& && &&&Target.Value = 1
& & Else
& && &&&Target.Value = &&
& & End If
End If
End Sub
复制代码
阅读权限20
在线时间 小时
dsmch 发表于
dsmch老师高明！还要请教一下，象您这样带行号能缩进的代码用什么工具编辑的呢？
按tab缩进，设置：代码窗口，工具、选项、自动缩进、设置tab宽度。一般为4&
阅读权限100
在线时间 小时
& & & & & & & &
<font color="#3579022 发表于
dsmch老师高明！还要请教一下，象您这样带行号能缩进的代码用什么工具编辑的呢？
带行号是论坛的功能
阅读权限20
在线时间 小时
谢谢两位！
阅读权限50
在线时间 小时
AVEL 发表于
带行号是论坛的功能
我怎么没看到呢？
阅读权限100
在线时间 小时
jiangwh15 发表于
我怎么没看到呢？
跟浏览器有关系。
我用的世界之窗就看不到代码行号。
用IE就可以看到了。
阅读权限10
在线时间 小时
Private Sub Worksheet_SelectionChange(ByVal Target As Range)&&'类似单击事件
Application.EnableEvents = False
& &If Target.Column = 1 And Target.Row &= 2 And Target.Row &= 9 And Target.Cells.Count = 1 Then
& && && &If Cells(Target.Row, 2) = &√& Then
& && && && &Cells(Target.Row, 2) = &&
& && && && &Cells(Target.Row, 2).Select
& && && &Else
& && && && &Cells(Target.Row, 2) = &√&
& && && && &Cells(Target.Row, 2).Select
& && && &End If
Application.EnableEvents = True
(12.58 KB, 下载次数: 390)
17:33 上传
点击文件名下载附件
最新热点 /1
本活动是由微软（中国）有限公司发起，申请通过者可以得到Office 365企业级E3 试用账号，并享有全套Office 365客户端及云端高效、协作办公体验。 机会有限，先到先得！
玩命加载中，请稍候
玩命加载中，请稍候
Powered by
本论坛言论纯属发表者个人意见，任何违反国家相关法律的言论，本站将协助国家相关部门追究发言者责任！ & & 本站特聘法律顾问：徐怀玉律师 李志群律师如何单击一个EXECL的单元格就触发一个VBA事件,即:单击事件_VB论坛_VBA-VB论坛-华_百度知道
该问题可能描述不清，建议你
如何单击一个EXECL的单元格就触发一个VBA事件,即:单击事件_VB论坛_VBA-VB论坛-华
答题抽奖
首次认真答题后
即可获得3次抽奖机会，100%中奖。
采纳数：34
获赞数：75
点击工作表标签查看代码,将一下代码复制进入光标所在区域内:Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column = 1 And Target.Count = 1 Then
MsgBox &你选中了:& & Target.Text
End IfEnd Sub****点击A列的单元格,且选中的是1个单元格时触发事件
采纳数：135
获赞数：1000
按ALT+F11打开VBA编辑窗口，如果只在其中一张工作表触发事件，那么双击左边工作表名称，如果要在当前工作簿所有工作表触发事件，请双击左边ThisWorkbook，将以下代码粘贴上去：Private&Sub&Workbook_SheetSelectionChange(ByVal&Sh&As&Object,&ByVal&Target&As&Range)If&Target.Address&=&&$A$1&&Then&&&MsgBox&&你单击了A1单元格，触发了事件！&,&vbOKOnly,&&测试&'你可以在这里编写你其它的代码End&IfEnd&Sub上述代码，实现单击A1单元格时触发事件，如要改为其它单元格，请修改上述代码。附图，希望能帮到您。
本回答被网友采纳
jackychen0
jackychen0
采纳数：839
获赞数：4251
VBA有这个事件，把代码写在工作表的以下过程中：Private Sub Worksheet_SelectionChange(ByVal Target As Range)'你的代码End Sub
为你推荐：
其他类似问题
您可能关注的内容
个人、企业类
违法有害信息,请在下方选择后提交
色情、暴力
我们会通过消息、邮箱等方式尽快将举报结果通知您。当前位置： >>
VBA学习笔记
EXCEL 之 VBA 学习笔记姓名：刘磊 时间：2015 年 91 / 52 目录第一章 VBA 基础知识 ................................................................................................................. 3 第二章 工作簿以及工作表的操作 ....................................................................................... 9 第三章：单元格区域操作 ..................................................................................................... 14 第四章：事件程序:................................................................................................................ 36 第五章：VBA 数组 ............................................................................................................... 432 / 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 Single Double Long String 可包含大约 20 亿 ( 2^31)个字符。 定长字符串可包含 1 到大约 64K ( 2^16 ) 个字 符。) Currency 6:if 条件语句 1.单行形式 1（If...Then） 货币型 @ 8Byte 注释 整型 单精度 双精度 长整型 字符型 ! # & $ 简写 % 占用内存 2Byte 4Byte 8Byte 4Byte 定长或变长( 变长字符串最多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 Sub4.块形式的 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 Sub7：select 语句用于判断选择Select case Case 1 Case 2 ….. Case else End select8：循环语句（1）：do loop 语句 Do ….. Loop (2):do while Do Loop （3）do until loop 语句 Do Loop [注]：while 与 until 不但可以放在 DO 后面，也可以放在 LOOP 后面事实上有时在循环的最后 一行进行判断，更具有意义。 Do [{While | Until} 表达式] [执行的一条或多条语句] [Exit Do] [执行的一条或多条语句] Loop --------------------------------------------------------------------------------while：当这个条件为 True 时就 循环 until：直到这个条件为 True 时就 跳出循环 --------------------------------------------------------------------------------until (直到条件成立) while loop 语句 (条件成立时候循环)5 / 52 或者可以使用下面这种语法: Do [执行的一条或多条语句] [Exit Do] [执行的一条或多条语句] Loop [{While | Until}表达式] --------------------------------------------------------------------------------用 Do?Loop 循环要注意的几点: 1. 2. 3. 4. While 与 Until 是放在 Do 后面还是 Loop 后面， 取决于是先判断再循环， 还是先循环再判断。 可以在 Do...Loop 中的任何位置放置任意个数的 Exit Do 语句，随时跳出 Do...Loop 循环。 Do...Loop + If...Then + Exit Do 通常结合使用. 如果 Exit Do 使用在嵌套的 Do...Loop 语句中，则 Exit Do 会将控制权转移到 Exit Do 所 前者则在 Do 后面，后者则在 Loop 后面。在位置的外层循环。 （4）：for each next 语句 Eg: Sub foreachnext 循环 1() Dim rng As Range, n! (range 为单元格对象) For Each rng In Sheet1.Range(&a2:a10&) 取 a2:a10 中的每个单元格 If rng = &A1& Then rng.Interior.ColorIndex = 3 Next End Sub Sub foreachnext 循环 2() Dim wsh As Worksheet, n As Byte, m As String n=n+1 Sheet1.Cells(n, 3) = wsh.Name Next End Sub （worksheet 为工作表变量） For Each wsh In Worksheets 取当前工作表集合中的每个成员9：exit 语句与 end 语句 （1）： exit 是退出当前语句1.Exit Do 2.Exit For 3.Exit Function 4.Exit Sub（2）：结束一个过程或块 End End FunctionEnd IfEnd Select End Sub [注]：end 有时候在某些地方的功能和 exit for 的作用相同。6 / 52 10：跳转语句GoTo line 无条件地转移到过程中指定的行。 Gosub return 跳转到某行，而且能够返回。 注意太多的 GoTo 语句，会使程序代码不容易阅读及调试。尽可能使用结构化控制语句(Do...Loop、 For...Next、If...Then...Else、Select Case)。 For example Sub gotoreturn() Dim i! For i = 2 To 10 If Sheet1.Range(&a& & i) & 1 / 3 Then GoSub 100 Next i Exit Sub 100: Return End Sub (作为 gosub 的跳转标示符号) Sheet1.Range(&b& & i) = &迟到& （return 语句返回到跳转的地方）11：对错误语句的处理方法 1： On Error Resume Next 方法 2： On Error goto 当错误时候去哪儿。 当错误的时候继续执行下去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 Sub13:VBA 与公式For example Sub 普通公式() Sheet1.Cells(1, 3) = &=a1+b1&7 / 52 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& End Sub Sub 公式带引号的计算() Cells(12, 1) = &=COUNTIF(A1:A10,&&&9&&)& 够使公式的输入格式正确） Cells(12, 2) = &=sum(INDIRECT(&&a1:a10&&))& End Sub （如果公式当中含有引号，则需要添加双重引号，才能 (FormulaArray 为数组公式)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 工作簿打开的个数 返回第 N 个工作簿的名称 Windows(N).parent.Name 返回工作表的名称 返回工作簿对象的父对象[注：工作簿索引号的表示法与窗口表示法表示的工作簿的顺序相反。]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&, &c:\321.txt& Kill &c:\321.txt& End Sub （对所有文件类型都起作用） (默认为自动保存，不提示)4：工作薄的应用实例 （1） 判断文件是否存在Sub 文件是否存在() a = Dir(&c:\123.xls&) If a = && Then （Dir 函数用来取出路径下的目录文件）9 / 52 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 Sub5：工作簿的表示方法在 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)与 WorkSheets(1)引用的可能不是同一个表。 Sub worksheetss()10 / 52 MsgBox Worksheets(1).Name MsgBox Sheets(1).Name End Sub Sub sheetss() For i = 1 To Sheets.Count MsgBox Sheets(i).Name Next End Sub6：工作表集合的应用（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 a = Sheets(i).Name If Sheets(i).Name = &我的工作表& Then MsgBox &存在& Exit Sub End If Next MsgBox &不存在& （Sheets.Count 指 sheet 里面的数量）11 / 52 End Sub7：工作表的增加与删除Sheets.Add 方法 表达式.Add(Before, After, Count, Type) XlSheetType 常量之一: xlWorksheet 工作表 xlChart 图表 xlExcel4MacroSheet 宏表 xlExcel4IntlMacroSheet 对话框 默认值为 xlWorksheet? Sub 新建 sheets()Sheets.AddSheets.Add Sheets(&abc&) Sheets.Add , Sheets(&abc&) Sheets.Add Count:=2 Sheets.Add , , 2 Sheets.Add , , , xlChart End Sub Sub 删除工作表() Sheet10.Delete End Sub（默认在活动工作表之前添加一个工作表） （在工作表名为 ABC 的工作表之前添加一个工作表） （在工作表名为 ABC 的工作表之后添加一个工作表） （与上式等价） （在活动工作表前添加两个工作表） （与上式等价） （添加图表）Sheets.Add after:=Sheets(&abc&)8：工作表的删除与添加 如果想批量新建工作表，可以结果循环来制作Sub 新建 1 到 12 月份的工作表() Dim j% For j = 12 To 1 Step -1 Sheets.Add.Name = j & &月& Next End Sub '删除工作表 Sub 删除 sheet() On Error Resume Next Application.DisplayAlerts = False Dim i% For i = 1 To 12 Sheets(i & &月&).Delete Next Application.DisplayAlerts = True （当屏幕有警告提示时候忽略关闭，否则，下次运行代 码时候依旧是忽略关闭状态） （当出现错误时候忽略错误） （当屏幕有警告提示时候忽略开启）12 / 52 End Sub9：工作表的移动与复制 （1） 工作表的复制表达式.copy(Before, After) Sub 复制() Sheet1.Copy Sheets(Sheets.Count) End Sub（2） 工作表的移动'表达式.Move(Before, After) Sub 移动() Sheet1.Move , Sheet3 End Sub10：工作表的选择与激活 Worksheet.Select 方法Worksheet.Activate 方法 Worksheets.Select Sheets.Select End Sub （2）：Sub 自定义选择() Worksheets(Array(1, 3, 5)).Select End Sub不支持隐藏选取支持隐藏选取（1）： Sub 快速选择所有工作表()（只选择工作表） （工作表，图表等全部选择）11：拆分工作簿实例Sub 拆分到工作簿() Dim wk As Workbook, ss$, k% Application.DisplayAlerts = False For Each sht In Workbooks(&2-11.工作簿综合运用(拆分工作簿)&).Sheets Set wk = Workbooks.Add 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 wk 为一个对象，对象的方法为添加工作表 声明 wk 为一个工作簿类型变量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&, &b10&).Select '变化写法 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 Sub3：range 变量与引用 （1）：range 的变化写法1):range(&地址区域&).range(&地址区域&) Sub 序号表示法() Range(&b2:d4&).Range(&b2&).Select '相对引用的写法 '参照前一个 range 的左上单元格 End Sub14 / 52 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&, &c& & i).Select '选择 A1 到 C 列的最后一格（方法一） Range(&a1:c& & i).Select '选择 A1 到 C 列的最后一格（方法二） 小结：动态单元格区域的定位，可以应用到单据的保存等实际工作中 End Sub4：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 '从左到右，从上到下 Range(&b3:f11&)(6).Select '与上一句相等 End Sub '注意：15 / 52 '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(64 + b) & a)).Select '利用 chr 函数，让字母形式的列号也支持变量 End Sub Sub chr 函数字符循环() For i = 1 To 65535 Cells(i, 1) = i Cells(i, 2) = Chr(i) Next End Sub7：三种单元格引用小结功能 引用对象 变量支持 书写难易 Range 单元格，区域，行，列 支持 难 Cells 单元格 支持 难 [单元格地址] 单元格，区域，行，列 不支持 易Range(&a1:c& & i).Select '引用单元格是区域且有变量 Cells(i, &c&).Select '引用的是单个单元格且有变量16 / 52 [a1:19].Select '引用的是区域或单元格且无变量8：行列的引用'行列引用 Sub 列引用() Columns(1).Select Columns(&b&).Select Columns(&c:e&).Select End Sub Sub 行引用() Rows(1).Select Rows(&2&).Select Rows(&3:4&).Select End Sub Sub range 行列表式法() Range(&1:1&).Select Range(&2:4&).Select Range(&a:a&).Select Range(&b:d&).Select 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&, Cells(a, b)).Select End Sub （返回第一列当中使用的（非空）单元格数目） （返回第一行中使用的（非空）单元格数目） （动态引用单元格） （第一行） （2 到 4 行） （a 列） （B 到 D 列） （3 到 4 行） （b 列） （c 到 e 列）9: row 与 column 属性Range.Row 属性 '返回区域中第一个子区域的第一行的行号17 / 52 'Range.Column 属性 '返回指定区域中第一块中的第一列的列号 Sub test() i = Range(&a3:b9&).Range(&a5&).Row 的真实行号） j = Range(&a3:b9&).Row i = Range(&b3:d9&).Range(&a5&).Column j = Range(&b3:d9&).Column End Sub （返回 A3 到 B9 区域的第一行第五列所在单元格位置实例： Sub row 应用()For Each rw In Rows(&1:13&) If rw.Row Mod 2 = 0 Then rw.RowHeight = 5 End If Next rw End Sub （将偶数行的行高设置为 5，其中 mod 为求余函数）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 Next18 / 52 For Each rng In Sheet3.Range(&b2:d10&) If rng = && Then rn = rn & rng.Address & &,& Next Range(Left(rn, Len(rn) - 1)) = &未考& 字符） End Sub （left 函数返回从左开始取字符串中, Len(rn) C 1 长度个11：单元格的移动与复制'-----------------------------------------------------------'1.Range.Cut 方法 '将单元格区域剪切到指定的区域 '2.Range.Copy 方法 '将单元格区域复制到指定的区域 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 '注： '1.等号后的区域一定要加 value.否则不成功 '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, s19 / 52 m = Application.CountA(Columns(1)) For r = 1 To m / 2 Rows(r).Delete Next End Sub13：活动单元格与选择区域活动单元格：activecell,工作表中活动单元格只有一个 Sub activecells() a = activecell.Address Cells(2, 3).Activate End Sub 'selection 光标所选区域 Sub 光标所选区域() Selection = 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 的好处在于，可以很自由灵活选择你想要处理的单元格区域 （激活所选区域单元格） （光标所选区域的每一个单元格的值赋为 1） '取得活动单元格地址 '激活指定单元格14： UsedRange 已使用区域(条件统计)'Worksheet.UsedRange 属性 '返回一个 Range 对象，该对象表示指定工作表上所使用的区域 Sub 已使用区域() Sheet1.UsedRange.Select 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&, Cells(8, c)) c.FormulaArray = &=& & a & &+& & b End Sub 'usedrange 与 currentregion '如果表中只有一个区域，两者最后的结果是一样的 '只是表达方式不一样 Sub u 与 c() Sheet3.UsedRange.Select [a1].CurrentRegion.Select End Sub （此为一数组公式，formulaArray 为数组公式）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 Sub17：单元格的 resize 属性(单据数据保存)'Range.Resize 属性 '调整指定区域的大小。返回 Range 对象，该对象代表调整后的区域。 '语法 '表达式.Resize(行数, 列数) '表达式 Sub test() [a1].Resize(2, 3).Select [a1].Resize(2).Select [a1].Resize(, 3).Select End Sub Sub 保存() Dim i%, j%, k% i = [a1].CurrentRegion.Rows.Count - 1 j = [a1].CurrentRegion.Columns.Count k = Application.CountA(Sheet2.Columns(1)) [a2].Resize(i, j).Copy Sheet2.[a1].Offset(k) End Sub 一个返回 Range 对象的表达式。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 Sub19：定位条件'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 Selection.EntireRow.Delete Exit Sub 100: MsgBox &没有空行& End Sub20：find 查找方法'Range.Find 方法 '在区域中查找特定信息23 / 52 '语法 '表达式.Find(What, After, LookIn, LookAt, SearchOrder, SearchDirection, MatchCase, MatchByte, SearchFormat) '表达式 一个代表 Range 对象的变量。Sub 查找最后一个单元格() Set endrng = Cells.Find(&*&, , xlFormulas, , , xlPrevious) Range([a1], endrng).Select End Sub21：find 查找系统 'Sub 查询系统() ends = Columns(1).Find(&*&, , , , , searchdirection:=xlPrevious).Row '动态找到 A 列的最后一个单元 格 Range(&g3:l999&).Clear '清除之前所有的筛选结果 For Each Rng In Range(&a2:a& & ends)MatchByte TRUE:区分 m=m+1 （打勾） If Rng Like Range(&h1&) Then '如果条件成立，那么 FLASE:不区 k=k+1 分 （不打勾）Range(&a& & m + 1 & &:e& & m + 1).Copy Range(&g& & k + 2) '将记录复制到另一个区域 End IfNext End Sub22：进销存之入库单Sub 开单() Set es = Cells.Find(&*&, , xlFormulas, , , xlPrevious) 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: Set es = Cells.Find(&*&, , xlFormulas, , , xlPrevious)24 / 52 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(&*&, , xlFormulas, , , xlPrevious) For Each Rng In Range([c5], es) Rng.Offset(0, 2) = Rng.Offset(0, 1) * Rng Next End Sub23：单元格 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&, Cells(i, &n&)) = && '将最后付款月下的区域清空 For j = 2 To i k = Cells(j, &n&).End(xlToLeft).Column '找到最后付款月所在的列号 Cells(j, &n&) = Cells(1, k) '将对应的月份填入对应的单元格 Next j End Sub24：查找最后一个单元格的 N 种方法'这里讨论怎样找到最后一个单元格！ '不考虑最后量个单元格是：是公式，错误值，隐藏之类的特殊情况。 '以最后是一个常规的值为准。且以 A 列的最后一个单元格为准 '--------------------------------------------------------------Sub 最后的单元格() a = Cells(Rows.Count, 1).End(xlUp).Row 'end 属性 b = Columns(1).Find(&*&, , , , , xlPrevious).Row 'find 方法 c = Cells.SpecialCells(xlCellTypeLastCell).Row 'specialcells 方法 d = Sheet1.UsedRange.Rows.Count 'usedrange 属性 e = [a1].CurrentRegion.Rows.Count 'currentregion 属性 f = WorksheetFunction.CountA([a:a]) '工作表函数 counta25 / 52 g = Application.CountIf([a:a], &&&&) '工作表函数 countif End Sub25：单元格的合并'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 SubSub 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 Sub26：单元格的交集'Application.Intersect 方法 '返回一个 Range 对象，该对象表示两个或多个区域重叠的矩形区域。 Sub test() If Intersect([a1:d10], Selection) Is Nothing Then '注释： Is Nothing 用于判断对象是否存在， 对象可 以是工作簿，工作表，单元格区域等 MsgBox &没有交集& Else26 / 52 MsgBox Intersect([a1:d10], Selection).Address Intersect([a1:d10], Selection).Select End If End SubSub 隔行插入() For i = 0 To Application.CountA(Columns(1)) * 2 Step 2 Intersect([a1:d2].Offset(i), [a2:d3].Offset(i)).EntireRow.Insert Next End Sub27：单元格数字格式的设置代码'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(&*&, , xlFormulas, , , xlPrevious) 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 Sub28：单元格字体格式设置代码实现'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 Sub29：底纹颜色的设置'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 Cells(i + 1, 1).Interior.Color = QBColor(i)28 / 52 Cells(i + 1, 2) = i Next i End Sub Sub 三原色颜色值() Cells(2, 4).Interior.Color = RGB([a1], [b1], [c1]) End SubSub 直接颜色值() '此颜色有 255^3 种颜色 Cells(1, 1).Interior.Color = [b1] End Sub30：单元格格式设置实例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 i = Application.FindFormat.Interior.Color Set erng = Cells(Rows.Count, &e&).End(xlUp) For Each rng In Range([b2], erng) If rng.Interior.Color = i Then k = k + rng.Value: n = n + 1 Next （利用查找颜色的功能返回拾取的颜色）29 / 52 MsgBox &最后平均分为：& & k / n & &分& End 100: MsgBox &查找功能没有拾取到颜色！& End Sub32：粘贴Option Explicit 'Worksheet.Paste 方法 '将“剪贴板”中的内容粘贴到工作表上。 '表达式.Paste(Destination, Link) '表达式 一个代表 Worksheet 对象的变量。Sub 粘贴() Range(&B1:B6&).Copy Range(&c9&) Range(&B1:B6&).Copy End Sub '复制区域无公式 Sheet1.Paste Range(&c9&) '粘贴到 c4 单元格Sub 粘贴 2() Range(&c1:c6&).Copy End Sub '复制单元格有公式 Sheet3.Paste '如果不指定 Destination 参数，则在使用该方法之前必须选择目标区域。Sub 粘贴 1() Range(&c1:C6&).Copy Sheet3.Paste , True ' Application.CutCopyMode = True End Sub '复制 c1 单元格33：选择性粘贴Option Explicit 'Range.PasteSpecial 方法 '将 Range 从剪贴板粘贴到指定的区域中。 '语法 '表达式.PasteSpecial(Paste, Operation, SkipBlanks, Transpose) '表达式 一个代表 Range 对象的变量。30 / 52 Sub 选择怪粘贴() Range(&c2:c10&).Copy Range(&d2&).PasteSpecial 12 End SubSub 选择怪粘贴运算() 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 Sub31 / 52 34：合并单元格Option Explicit 'Range.Merge 方法 '由指定的 Range 对象创建合并单元格。Sub 合并单元格() Selection.Merge End SubSub 合并单元格实例() 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 Sub35：合并单元格实例与取消合并单元格'----------------------------------------------------------------------'Range.MergeArea 属性 '返回一个 Range 对象，该对象代表包含指定单元格的合并区域。 'Range.UnMerge 方法 '将合并区域分解为独立的单元格 '-------------------------------------------------------------------------Sub test() a = Range(&a1&).MergeArea.Count [a1].UnMerge End SubSub 解除合并单元格后保持原来的数据() Dim b%, rng As Range For Each rng In Selection b = rng.MergeArea.Count32 / 52 rng.UnMerge rng.Resize(b) = rng Next End Sub36：有条件的添加批注'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 If Rng &= 90 Then Rng.AddComment.Text &优秀& Next End Sub37：修改批注（注意文件地址的书写方式）'修改批注 Sub 修改批注() Range(&a2&).AddComment '添加批注 [a2].Comment.Shape.Height = 50 '设置批注高度 [a2].Comment.Shape.Width = 40 '设置批注宽度 [a2].Comment.Shape.Fill.UserPicture ThisWorkbook.Path & &\7pic\阿汤.png& End Sub Sub 批量将批注增加背景()33 / 52 For Each Rng In Selection paths = ThisWorkbook.Path & &\7pic\& & Rng.Value & &.png& Rng.ClearComments Rng.AddComment Rng.Comment.Shape.Height = 50 Rng.Comment.Shape.Width = 40 '设置批注宽度 Rng.Comment.Shape.Fill.UserPicture paths Next End Sub38：图形基础'Shapes 对象 '指定的工作表上的所有 Shape 对象的集合。 '说明 '每个 Shape 对象都代表绘图层中的一个对象，如自选图形、任意多边形、图片、图表等。Sub abc() Dim ob As Shape n = Sheet1.Shapes.Count 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 图形插入() Sheet3.Shapes.AddPicture ThisWorkbook.Path & &\7pic\林志玲.png&, _ True, True, 100, 100, 70, 70 End Sub Sub 图形删除() For Each shp In Sheet3.Shapes shp.Delete Next shp End Sub '图形名称 '图形类型 '顶端坐标 '左端坐标 '宽度 '高度39：图形的插入应用实例Sub 宏 1()34 / 52 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) Sheet1.Shapes.AddPicture i, True, True, rngs.Left, rngs.Top, rngs.Width, rngs.Height Next Rng End Sub40：多表合并'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 rs = st.UsedRange.Rows.Count ' 计算 1-3 月份每个表的最后一行 rss = zst.UsedRange.Rows.Count + 1 '计算“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 Sub41：多表拆分Sub 多表拆分() For f = 1 To 3 '循环三次（只拆分三个月） Worksheets.Add.Name = f & &月& '新建工作表，并以月份命名 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 Sub35 / 52 第四章：事件程序:1：事件程序定义与作用'1.定义 'excel 事件程序：因为一个操作(动作)而触发了一段程序。让程序发生了运行。 '就像机关设置'2.实例 '例 1：打开工作表 1，则运行一段程序（选择工作表 1 触发程序） '例 2：保护工作表数据实例。'3.作用 'excel 事件程序的作用：以前程序只能通过手工运行或指定宏功能来完成 '事件程序则可以却因不同的操作而自动触发运行不同的程序。 '4.代码位置 'excel 事件程序代码存放在位置 '----------------------------------'事件类型 代码位置 '----------------------------------'工作表事件 工作表 '工作簿事件 工作簿(thisworkbook) '程序事件 工作簿(thisworkbook)或类模块2：事件程序基础'代码存储位置 '事件 '------------------------------------------------------'应用程序-根据应用程序的动作进行控制 关事件 '工作簿-根据工作簿的动作进行控制 关事件 '工作表-根据工作表的动作进行控制 的相关事件 sheet1.sheet2.... 对工作表中所有单元操作 thisworkbook 对所有工作表操作的相 类模块或 thisworkbook 对所有工作簿操作的相 代码位置'2.括号里面是参数(传回值用法)36 / 52 '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 WorkbookPivotTableCloseCloseConnection WorkbookPivotTableOpenCloseConnection WorkbookRowsetCompletd Workbooksync 注释 当新建一个工作簿时发生此事件 当激活任何工作表时发生此事件 在双击任何工作表前发生此事件 右键单击任何工作表前发生此事件 在重新计算工作表时发生此事件 更改任何工作表的单元格时发生此事件 当工作表失去焦点时发生此事件（离开工作表时）。 在单击工作簿中的任何超链接时发生。 在更新数据透视表的工作表后发生。 所选内容在任何工作表上更改时发生。 在激活任何工作簿窗口时发生。 工作簿的窗口变为非活动状态时，将产生本事件。 改变工作簿窗口大小时发生 当激活任何工作簿时发生此事件 工作簿为加载宏安装时发生此事件 当任一工作簿作为卸载宏时发生 在保存或导出工作簿中的 XML 数据之后发生此事件 发生 关闭任何工作簿前发生此事件 在打印工作簿前发生此事件 在保存任何工作簿前发生引事件 保存或导出 XML 数据前发生的事件 发生 当打开的工作簿转为非活动状态时发生此事件 在任何打开的工作簿中新建工作表时发生此事件 当打开一个工作簿时发生此事件 在数据透视表的链接关闭之后发生此事件 在数据透视表的链接打开之后发生此事件 如果用户在 OLAP 数据透视表上深化记录集或调用行集操作，则会发生 WorkbookRowsetComplete 事件 此事件 37 / 52当刷新现有的 XML 数据链接或新的 XML 数据被导入任一打开的 Excel 工作簿之后时当刷新现有的 XML 数据链接或新的 XML 数据被导入任一打开的 Excel 工作簿之前时当作为“文档工作区”一部分的工作簿的本地副本与服务器上的副本进行同步时发生 工作簿事件 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 数据之后发生此事件 生此事件 是否保存更改之前产生。 在打印指定工作簿（或者其中的任何内容）之前，发生此事件 保存工作簿之前发生此事件 在 Excel 保存或导出指定工作簿中的 XML 数据之后发生此事件 生此事件 图表、工作表或工作簿被停用时发生此事件 当在工作簿中新建工作表时发生此事件 打开工作簿时，发生此事件 数据透视表关闭与其数据源的链接后发生此事件 数据透视表打开与其数据源的链接后发生此事件 如果用户在 OLAP 数据透视表上深化记录集或调用行集操作，则会引发此事件 当激活任何工作表时发生 此事件 当双击任何工作表时发生此事件，此事件先于默认的双击操作发生 右键单击任一工作表时发生此事件，此事件先于默认的右键单击操作 在重新计算工作表时或在图表上绘制更改的数据之生发生此事件 当用户或外部链接更改了任何工作表中的单元格时发生此事件 当任何工作表停用时发生此事件 单击 Excel 中的任何超链接时发生此事件 在数据透视表的工作表更新之后发生此事件 任一工作表的选定区域发生更改时，将发生此事件在刷新现有的 XML 数据链接或将新的 XML 数据导入到指定的 Excel 工作簿之后，发在关闭工作簿之前，先产生此事件。如果该工作簿已经更改过，则本事件在询问用户在刷新现有的 XML 数据链接或将新的 XML 数据导入到指定的 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 Sub4 工作表事件实例 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 Sub5：工作表事件实例（自动列出工作表名与单元格区域保护）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 Sub6：工作簿事件实例 1（自动选择月份表、右键禁用、打印控制）'事件中的 Cancel: ' 默认为 false，在完成事件内代码效果后，接着继续完成操作的后续效果。 ' 而为 true 时，在完成事件内代码效果后，终止当前操作的后续效果。 ' 相当于给用户控制事件提供一个开关。可以把用户自定义事件代替默认事件 ' 没有 Cancel 就是说不给你这个控制权限，一旦一始就要按流程结束。 Private Sub Workbook_Open() mon = Format(Now(), &m&) Sheets(mon & &月&).Select End SubPrivate Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean) Cancel = True '禁用右键 End SubPrivate Sub Workbook_BeforePrint(Cancel As Boolean) If Month(Now()) & &月& && ActiveSheet.Name Then MsgBox &不能打印& Cancel = True Else MsgBox &能打印&40 / 52 Cancel = False End If End Sub7：工作簿事件实例 2（给工作表加密码）'Application.EnableEvents 属性 'Application.EnableEvents = True/FALSE '如果对指定对象启用事件，则该属性值为 True。Boolean 类型，可读写。 '作用：临时关闭，防止死循环 'Private Sub Workbook_Open() 'Application.EnableEvents = True 'Sheet2.Cells.Font.Color = RGB(255, 255, 255) 'Sheet3.Activate 'End Sub Private Sub Worksheet_Activate() '激活工作表触发的程序 a = InputBox(&请输入密码&) If a = 123 Then Cells.Font.Color = RGB(0, 0, 0) Application.EnableEvents = False Else Sheet3.Activate End If End Sub8：应用程序事件'应用程序事件：是对每个打开工作簿操因操作所发生的事件程序 '应用程序事件代码位置：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 文件中。例子：任何时候都不能增加工作表 Private Sub excelapp_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) '4-8 课内9：应用程序事件实例41 / 52 容 Application.StatusBar = &选择区域是：& & Target.Address(0, 0) '任意工作表显示选择区域地址 End SubPrivate 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 Sub10：事件总结1.各种事件的作用范围 工作表：作用于某个工作表下的所有单元格操作 工作簿：作用于某个工作簿下的所有工作表 应用程序:作用于所有工作簿。 2.各种事件过程代码的执行顺序 工作表事件→工作薄事件→应用程序事件42 / 52 第五章：VBA 数组1：数组基础' ' ' ' ' ' ' ' ' ' ' ' ' ' ' Sub test2() Dim arr1(3) Dim arr2(1 To 3) Dim arr3(1 To 3, 1 To 2) Dim arr4(3, 2) End Sub 5.当我们学会了数组，会发现以前的写的很多代码可以从数组的角度重写 3.数组特点 a.读写速度快（从内存读取数据要比从硬盘读取快） b.无法永远保存(内存只是暂存空间) 4.数组分类 a.一般分为：常量数组，静态数组，动态数组 b.如按维度为：1 维，2 维，3 维......60 维 2.数组位置 数组存储在内存中. 1.数组概念 数组就是一个列表或者一组数据表.2：数组维度' ' ' ' Sub test1() arr1 = [{&A&,&B&,&C&,&D&}] arr2 = Application.Transpose([{1;2;3;4}]) End Sub Sub test2() arr3 = [{&张&,1;&王&,2;&陈&,3;&李&,4;&林&,5}] End Sub Sub test4() arr = Array(1, 2, 3, 4) arr1 = Array(Array(&a&, &b&), Array(1, 2, 3)) 【转置】 数组最多有 60 维，但在 excel 中一般最到 2 维 1.excel 中的一行或一列可以转换 1 维数组 2.excel 中的多行多列可以转换成 2 维数组43 / 52 End Sub3 向数组中写数据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&, &B&, &A&, 9) End Sub Sub 单元格区域数据批量写入数组() arr = Application.Transpose([a1:a4]) '注意：当向数组中批量写入多行，结果就是二维数组 arr1 = Application.Transpose(Application.Transpose([a7:d7])) End Sub4:在数组中取数据'怎样在数组中取数 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] arr1 = Application.Transpose(arr) [a7:d7] = arr1 [a8:c8] = arr1 [a9:e9] = arr144 / 52 '注意左右两边尺寸的对应 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 Sub6：数组写入与读取实例(数组的优势体现)'比比哪个程序的运行速度更快 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 Dim arr1(1 To 5000, 1 To 1) Set Rng = Cells(Rows.Count, 1).End(xlUp) arr = Range([a1], Rng) '数组写入 For Each a In arr45 / 52 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 Sub7：数组应用之计算不重复值'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 SubSub 利用数组提取不重复值() Dim arr1(1 To 10) Set lastcell = Cells(Rows.Count, &b&).End(xlUp) '查找最后 B 列最后一个非空单元格 arr = Range([b2], lastcell) For i = 1 To lastcell.Row - 1 For j = 1 To UBound(arr1) If arr(i, 1) = arr1(j) Then GoTo 100 End If Next j k=k+1 100: Next i [e2].Resize(k) = Application.Transpose(arr1) End Sub '循环结束后将 arr1 的结果赋值给单元格区域 '做个计数器，计算相等重复的元素人数 arr1(k) = arr(i, 1) '如果循环完后都没有相等的，则将 arr1 循环的元素赋值给 arr1 数组 'arr 数组元素与 arr1 元素循环对比，如果相等，则跳出内层循环 '将 B 列的姓名数据赋值给变量 arr 形成一个数组 '循环 B 列单元格个数的次数 '找到 arr1 数组的最大小标，形成循环x = arr(i, 1): y = arr1(j) '辅助代码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 形成一个数组46 / 52 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 Sub9：动态数组（条件筛选）'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&, rn) m = WorksheetFunction.CountIf(Range(&a2&, rn), &&=80&) '确定重新定义数组的上界【工作表函数】 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) End Sub 【定位最后一行】10：动态数组(多表合并)'Preserve 可选的。关键字，当改变原有数组最末维的大小时，使用此关键字可以保持数组中原 来的数据。 Sub abc() Dim arr() i=9 arr = [{1,2,3}]47 / 52 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 '目的：只有&汇总&工作表的数据不合并 ' 将各表的数据循环写入 arr1 c = sh.Name & &!& & sh.Range(&a2:b& & sh.UsedRange.Rows.Count).Address '帮助代码 arr1 = sh.Range(&a2:b& & sh.UsedRange.Rows.Count) 数组中 act = act + UBound(arr1) '累加各表数据的行数，作为重新声明 arr1 数组的上界 '重新声明数组 arr ReDim Preserve arr(1 To 2, 1 To act) 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 Sub11： 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 Sub 数据互换() arr = [a1].CurrentRegion For Each a In arr arr1 = Split(a, &-&) n=n+1 Cells(n, &c&) = arr1(1) & &-& & arr1(0) Next End Sub 【以 A1 单元格为扩展的单元格】12： Join 函数与数组（数组生成字符串）48 / 52 'Join 函数(作用于 1 维数组) '返回一个字符串，该字符串是通过连接某个数组中的多个子字符串而创建的。 'Join(数组,&连接符&)Sub test() arr = [{1,2,3,4}] i = Join(arr, &-&) End SubSub 数据合并() 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&,&bb&,&c&,&ba&,&dd&,&nba&}] a = Filter(arr, &b&, True) b = Filter(arr, &b&, 0) End SubSub 筛选() [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)49 / 52 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 Sub14：工作表函数与 VBA 数组(几句代码制作查询系统)'在工作表支持数组的函数，很多也支持 VBA 数组 '返回结果，当然也是一个数组 '如 sumif,countif,match,index,vlookup..... '工作表函数 INDEX 处理 VBA 数组 '如对 INDEX 函数不了解：请移驾自学网：http://www.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&, Cells(Rows.Count, &g&).End(xlUp)) 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) End If Next End Sub15:借助 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&)50 / 52 n=n+1 If n = 1 Then Set rngs = Rng Else Set rngs = Union(rngs, Rng) k = rngs.Address End If Next rngs.Interior.ColorIndex = 3 End Sub16:利用 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 Sub17: 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 arr1(1, n) = arr(i, 1) arr1(2, n) = arr(i, 3) 100: Next [e2].Resize(n, 2) = Application.Transpose(arr1) End Sub51 / 52 第六章：VBA 与字典技术52 / 52
VBA学习笔记系列---ExcelVBA 基础 - 1. 更改日期显示方式: 2. 公式应用:可以先设定一个单元格,其他进行自动填充。 3. 常用函数 3.1 数学与三角函数 3.1.1...VBA学习-控件-笔记-2016_电脑基础知识_IT/计算机_专业资料。excel VBA控件学习笔记2013版office EXCEL2013 版,EXCEL 学习 1 注:Ctrl+鼠标左键(打开目录链接) P21...VBA学习笔记 - Sub sss() Select Case Range(B1).Value Case Is = 1 MsgBox 1 代表入门 Case 2 MsgBox (2 代表基础) ...VBA学习笔记系列---VBA高级技术 - 1. Excel 打开 xml 文件: 在 Excel 中打开的效果如下: 现在我们在 Excel 中添加一条记录: 然后全部选中,右键:xm...Excel VBA 学习笔记 - 1. Excel 2010 可以运行宏但不能编辑啊? If 函数 2. 录制宏 你做什么他做什么。 Sub 生成工资条() Dim i As Long...VBA 学习笔记 - VBA 常用代码中英文对照 Range:单元格 CopyFromRecordset:拷贝 来自 记录集 Execute(sq1):执行 SQL Set rst = Noth...VBA 学习第七课笔记和代码: 一、 知识点: 1、'Range 表现单元格对象的第二种方法 'Range(起始单元格,终止单元格) 是以起始单元格为左上角,终止单元格为右...VBA自已学习笔记 - MsgBox Workbooks.Count 这是统计打开工作薄的数量 Workbooks 后再输入个点(.),就会出现一个下拉框,框中的带小手指的就是工作薄集合的属 性...VBA学习笔记系列---WorkBookworksheetsRange对象 - 1.在 Microsoft Excel 对象模型中, Workbook 对象表示一个 Excel.xls 工作 ...VBA学习笔记系列---VBA... 5页 1下载券 VBA 学习笔记 12页 2下载券 VBA...VBA 总共支持 13 种数据类型, 对象型是其中一种, 包括 application, workbook,...
All rights reserved Powered by
www.tceic.com
copyright ©right 。文档资料库内容来自网络，如有侵犯请联系客服。}
id: '3284507',
container: s,
size: '0,0',
display: 'inlay-fix'
excel用VBA选择工作表中所有包含超链接的单元格
要选择工作表中所有包含超链接的单元格，用定位或查找的方法无法实现。下面的VBA代码可以实现这一目的。
按Alt+F11，打开VBA编辑器，在&工程&窗口中双击某个工作表，在右侧的代码窗口中输入下列代码：
Sub SelectHyperlinkCells()
Dim hHlink As Hyperlink
Dim rRange As Range
Dim NotFirstlink As Boolean
On Error Resume Next
For Each hHlink In ActiveSheet.Hyperlinks
If NotFirstlink Then
Set rRange = Application.Union(rRange, hHlink.Range)
Set rRange = hHlink.Range
NotFirstlink = True
If rRange Is Nothing Then End
rRange.Select
关闭VBA编辑器返回工作表界面，按Alt+F8打开&宏&对话框，运行&SelectHyperlinkCells&宏即可选择工作表中所有包含超链接的单元格。
标签(Tag):
------分隔线----------------------------
------分隔线----------------------------
猜你感兴趣查看: 20843|回复: 13
VBA 单击单元格触发事件
阅读权限20
在线时间 小时
请大侠们帮忙
如何在单击某个区域的单元格时判断该单元是否为空
如果为空输入指定数值
如果不为空则输入空值
阅读权限95
在线时间 小时
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Value = && Then
& & Target.Value = 1
Else
& & Target.Value = &&
End If
End Sub
复制代码
阅读权限20
在线时间 小时
& & & & & & & &
dsmch 发表于
还有点小问题 我只要某个区域的单元格单击触发
阅读权限95
在线时间 小时
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Application.Intersect([a1:c10], Target) Is Nothing Then
& & If Target.Value = && Then
& && &&&Target.Value = 1
& & Else
& && &&&Target.Value = &&
& & End If
End If
End Sub
复制代码
阅读权限20
在线时间 小时
dsmch 发表于
dsmch老师高明！还要请教一下，象您这样带行号能缩进的代码用什么工具编辑的呢？
按tab缩进，设置：代码窗口，工具、选项、自动缩进、设置tab宽度。一般为4&
阅读权限100
在线时间 小时
& & & & & & & &
<font color="#3579022 发表于
dsmch老师高明！还要请教一下，象您这样带行号能缩进的代码用什么工具编辑的呢？
带行号是论坛的功能
阅读权限20
在线时间 小时
谢谢两位！
阅读权限50
在线时间 小时
AVEL 发表于
带行号是论坛的功能
我怎么没看到呢？
阅读权限100
在线时间 小时
jiangwh15 发表于
我怎么没看到呢？
跟浏览器有关系。
我用的世界之窗就看不到代码行号。
用IE就可以看到了。
阅读权限10
在线时间 小时
Private Sub Worksheet_SelectionChange(ByVal Target As Range)&&'类似单击事件
Application.EnableEvents = False
& &If Target.Column = 1 And Target.Row &= 2 And Target.Row &= 9 And Target.Cells.Count = 1 Then
& && && &If Cells(Target.Row, 2) = &√& Then
& && && && &Cells(Target.Row, 2) = &&
& && && && &Cells(Target.Row, 2).Select
& && && &Else
& && && && &Cells(Target.Row, 2) = &√&
& && && && &Cells(Target.Row, 2).Select
& && && &End If
Application.EnableEvents = True
(12.58 KB, 下载次数: 390)
17:33 上传
点击文件名下载附件
最新热点 /1
本活动是由微软（中国）有限公司发起，申请通过者可以得到Office 365企业级E3 试用账号，并享有全套Office 365客户端及云端高效、协作办公体验。 机会有限，先到先得！
玩命加载中，请稍候
玩命加载中，请稍候
Powered by
本论坛言论纯属发表者个人意见，任何违反国家相关法律的言论，本站将协助国家相关部门追究发言者责任！ & & 本站特聘法律顾问：徐怀玉律师 李志群律师如何单击一个EXECL的单元格就触发一个VBA事件,即:单击事件_VB论坛_VBA-VB论坛-华_百度知道
该问题可能描述不清，建议你
如何单击一个EXECL的单元格就触发一个VBA事件,即:单击事件_VB论坛_VBA-VB论坛-华
答题抽奖
首次认真答题后
即可获得3次抽奖机会，100%中奖。
采纳数：34
获赞数：75
点击工作表标签查看代码,将一下代码复制进入光标所在区域内:Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column = 1 And Target.Count = 1 Then
MsgBox &你选中了:& & Target.Text
End IfEnd Sub****点击A列的单元格,且选中的是1个单元格时触发事件
采纳数：135
获赞数：1000
按ALT+F11打开VBA编辑窗口，如果只在其中一张工作表触发事件，那么双击左边工作表名称，如果要在当前工作簿所有工作表触发事件，请双击左边ThisWorkbook，将以下代码粘贴上去：Private&Sub&Workbook_SheetSelectionChange(ByVal&Sh&As&Object,&ByVal&Target&As&Range)If&Target.Address&=&&$A$1&&Then&&&MsgBox&&你单击了A1单元格，触发了事件！&,&vbOKOnly,&&测试&'你可以在这里编写你其它的代码End&IfEnd&Sub上述代码，实现单击A1单元格时触发事件，如要改为其它单元格，请修改上述代码。附图，希望能帮到您。
本回答被网友采纳
jackychen0
jackychen0
采纳数：839
获赞数：4251
VBA有这个事件，把代码写在工作表的以下过程中：Private Sub Worksheet_SelectionChange(ByVal Target As Range)'你的代码End Sub
为你推荐：
其他类似问题
您可能关注的内容
个人、企业类
违法有害信息,请在下方选择后提交
色情、暴力
我们会通过消息、邮箱等方式尽快将举报结果通知您。当前位置： >>
VBA学习笔记
EXCEL 之 VBA 学习笔记姓名：刘磊 时间：2015 年 91 / 52 目录第一章 VBA 基础知识 ................................................................................................................. 3 第二章 工作簿以及工作表的操作 ....................................................................................... 9 第三章：单元格区域操作 ..................................................................................................... 14 第四章：事件程序:................................................................................................................ 36 第五章：VBA 数组 ............................................................................................................... 432 / 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 Single Double Long String 可包含大约 20 亿 ( 2^31)个字符。 定长字符串可包含 1 到大约 64K ( 2^16 ) 个字 符。) Currency 6:if 条件语句 1.单行形式 1（If...Then） 货币型 @ 8Byte 注释 整型 单精度 双精度 长整型 字符型 ! # & $ 简写 % 占用内存 2Byte 4Byte 8Byte 4Byte 定长或变长( 变长字符串最多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 Sub4.块形式的 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 Sub7：select 语句用于判断选择Select case Case 1 Case 2 ….. Case else End select8：循环语句（1）：do loop 语句 Do ….. Loop (2):do while Do Loop （3）do until loop 语句 Do Loop [注]：while 与 until 不但可以放在 DO 后面，也可以放在 LOOP 后面事实上有时在循环的最后 一行进行判断，更具有意义。 Do [{While | Until} 表达式] [执行的一条或多条语句] [Exit Do] [执行的一条或多条语句] Loop --------------------------------------------------------------------------------while：当这个条件为 True 时就 循环 until：直到这个条件为 True 时就 跳出循环 --------------------------------------------------------------------------------until (直到条件成立) while loop 语句 (条件成立时候循环)5 / 52 或者可以使用下面这种语法: Do [执行的一条或多条语句] [Exit Do] [执行的一条或多条语句] Loop [{While | Until}表达式] --------------------------------------------------------------------------------用 Do?Loop 循环要注意的几点: 1. 2. 3. 4. While 与 Until 是放在 Do 后面还是 Loop 后面， 取决于是先判断再循环， 还是先循环再判断。 可以在 Do...Loop 中的任何位置放置任意个数的 Exit Do 语句，随时跳出 Do...Loop 循环。 Do...Loop + If...Then + Exit Do 通常结合使用. 如果 Exit Do 使用在嵌套的 Do...Loop 语句中，则 Exit Do 会将控制权转移到 Exit Do 所 前者则在 Do 后面，后者则在 Loop 后面。在位置的外层循环。 （4）：for each next 语句 Eg: Sub foreachnext 循环 1() Dim rng As Range, n! (range 为单元格对象) For Each rng In Sheet1.Range(&a2:a10&) 取 a2:a10 中的每个单元格 If rng = &A1& Then rng.Interior.ColorIndex = 3 Next End Sub Sub foreachnext 循环 2() Dim wsh As Worksheet, n As Byte, m As String n=n+1 Sheet1.Cells(n, 3) = wsh.Name Next End Sub （worksheet 为工作表变量） For Each wsh In Worksheets 取当前工作表集合中的每个成员9：exit 语句与 end 语句 （1）： exit 是退出当前语句1.Exit Do 2.Exit For 3.Exit Function 4.Exit Sub（2）：结束一个过程或块 End End FunctionEnd IfEnd Select End Sub [注]：end 有时候在某些地方的功能和 exit for 的作用相同。6 / 52 10：跳转语句GoTo line 无条件地转移到过程中指定的行。 Gosub return 跳转到某行，而且能够返回。 注意太多的 GoTo 语句，会使程序代码不容易阅读及调试。尽可能使用结构化控制语句(Do...Loop、 For...Next、If...Then...Else、Select Case)。 For example Sub gotoreturn() Dim i! For i = 2 To 10 If Sheet1.Range(&a& & i) & 1 / 3 Then GoSub 100 Next i Exit Sub 100: Return End Sub (作为 gosub 的跳转标示符号) Sheet1.Range(&b& & i) = &迟到& （return 语句返回到跳转的地方）11：对错误语句的处理方法 1： On Error Resume Next 方法 2： On Error goto 当错误时候去哪儿。 当错误的时候继续执行下去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 Sub13:VBA 与公式For example Sub 普通公式() Sheet1.Cells(1, 3) = &=a1+b1&7 / 52 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& End Sub Sub 公式带引号的计算() Cells(12, 1) = &=COUNTIF(A1:A10,&&&9&&)& 够使公式的输入格式正确） Cells(12, 2) = &=sum(INDIRECT(&&a1:a10&&))& End Sub （如果公式当中含有引号，则需要添加双重引号，才能 (FormulaArray 为数组公式)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 工作簿打开的个数 返回第 N 个工作簿的名称 Windows(N).parent.Name 返回工作表的名称 返回工作簿对象的父对象[注：工作簿索引号的表示法与窗口表示法表示的工作簿的顺序相反。]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&, &c:\321.txt& Kill &c:\321.txt& End Sub （对所有文件类型都起作用） (默认为自动保存，不提示)4：工作薄的应用实例 （1） 判断文件是否存在Sub 文件是否存在() a = Dir(&c:\123.xls&) If a = && Then （Dir 函数用来取出路径下的目录文件）9 / 52 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 Sub5：工作簿的表示方法在 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)与 WorkSheets(1)引用的可能不是同一个表。 Sub worksheetss()10 / 52 MsgBox Worksheets(1).Name MsgBox Sheets(1).Name End Sub Sub sheetss() For i = 1 To Sheets.Count MsgBox Sheets(i).Name Next End Sub6：工作表集合的应用（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 a = Sheets(i).Name If Sheets(i).Name = &我的工作表& Then MsgBox &存在& Exit Sub End If Next MsgBox &不存在& （Sheets.Count 指 sheet 里面的数量）11 / 52 End Sub7：工作表的增加与删除Sheets.Add 方法 表达式.Add(Before, After, Count, Type) XlSheetType 常量之一: xlWorksheet 工作表 xlChart 图表 xlExcel4MacroSheet 宏表 xlExcel4IntlMacroSheet 对话框 默认值为 xlWorksheet? Sub 新建 sheets()Sheets.AddSheets.Add Sheets(&abc&) Sheets.Add , Sheets(&abc&) Sheets.Add Count:=2 Sheets.Add , , 2 Sheets.Add , , , xlChart End Sub Sub 删除工作表() Sheet10.Delete End Sub（默认在活动工作表之前添加一个工作表） （在工作表名为 ABC 的工作表之前添加一个工作表） （在工作表名为 ABC 的工作表之后添加一个工作表） （与上式等价） （在活动工作表前添加两个工作表） （与上式等价） （添加图表）Sheets.Add after:=Sheets(&abc&)8：工作表的删除与添加 如果想批量新建工作表，可以结果循环来制作Sub 新建 1 到 12 月份的工作表() Dim j% For j = 12 To 1 Step -1 Sheets.Add.Name = j & &月& Next End Sub '删除工作表 Sub 删除 sheet() On Error Resume Next Application.DisplayAlerts = False Dim i% For i = 1 To 12 Sheets(i & &月&).Delete Next Application.DisplayAlerts = True （当屏幕有警告提示时候忽略关闭，否则，下次运行代 码时候依旧是忽略关闭状态） （当出现错误时候忽略错误） （当屏幕有警告提示时候忽略开启）12 / 52 End Sub9：工作表的移动与复制 （1） 工作表的复制表达式.copy(Before, After) Sub 复制() Sheet1.Copy Sheets(Sheets.Count) End Sub（2） 工作表的移动'表达式.Move(Before, After) Sub 移动() Sheet1.Move , Sheet3 End Sub10：工作表的选择与激活 Worksheet.Select 方法Worksheet.Activate 方法 Worksheets.Select Sheets.Select End Sub （2）：Sub 自定义选择() Worksheets(Array(1, 3, 5)).Select End Sub不支持隐藏选取支持隐藏选取（1）： Sub 快速选择所有工作表()（只选择工作表） （工作表，图表等全部选择）11：拆分工作簿实例Sub 拆分到工作簿() Dim wk As Workbook, ss$, k% Application.DisplayAlerts = False For Each sht In Workbooks(&2-11.工作簿综合运用(拆分工作簿)&).Sheets Set wk = Workbooks.Add 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 wk 为一个对象，对象的方法为添加工作表 声明 wk 为一个工作簿类型变量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&, &b10&).Select '变化写法 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 Sub3：range 变量与引用 （1）：range 的变化写法1):range(&地址区域&).range(&地址区域&) Sub 序号表示法() Range(&b2:d4&).Range(&b2&).Select '相对引用的写法 '参照前一个 range 的左上单元格 End Sub14 / 52 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&, &c& & i).Select '选择 A1 到 C 列的最后一格（方法一） Range(&a1:c& & i).Select '选择 A1 到 C 列的最后一格（方法二） 小结：动态单元格区域的定位，可以应用到单据的保存等实际工作中 End Sub4：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 '从左到右，从上到下 Range(&b3:f11&)(6).Select '与上一句相等 End Sub '注意：15 / 52 '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(64 + b) & a)).Select '利用 chr 函数，让字母形式的列号也支持变量 End Sub Sub chr 函数字符循环() For i = 1 To 65535 Cells(i, 1) = i Cells(i, 2) = Chr(i) Next End Sub7：三种单元格引用小结功能 引用对象 变量支持 书写难易 Range 单元格，区域，行，列 支持 难 Cells 单元格 支持 难 [单元格地址] 单元格，区域，行，列 不支持 易Range(&a1:c& & i).Select '引用单元格是区域且有变量 Cells(i, &c&).Select '引用的是单个单元格且有变量16 / 52 [a1:19].Select '引用的是区域或单元格且无变量8：行列的引用'行列引用 Sub 列引用() Columns(1).Select Columns(&b&).Select Columns(&c:e&).Select End Sub Sub 行引用() Rows(1).Select Rows(&2&).Select Rows(&3:4&).Select End Sub Sub range 行列表式法() Range(&1:1&).Select Range(&2:4&).Select Range(&a:a&).Select Range(&b:d&).Select 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&, Cells(a, b)).Select End Sub （返回第一列当中使用的（非空）单元格数目） （返回第一行中使用的（非空）单元格数目） （动态引用单元格） （第一行） （2 到 4 行） （a 列） （B 到 D 列） （3 到 4 行） （b 列） （c 到 e 列）9: row 与 column 属性Range.Row 属性 '返回区域中第一个子区域的第一行的行号17 / 52 'Range.Column 属性 '返回指定区域中第一块中的第一列的列号 Sub test() i = Range(&a3:b9&).Range(&a5&).Row 的真实行号） j = Range(&a3:b9&).Row i = Range(&b3:d9&).Range(&a5&).Column j = Range(&b3:d9&).Column End Sub （返回 A3 到 B9 区域的第一行第五列所在单元格位置实例： Sub row 应用()For Each rw In Rows(&1:13&) If rw.Row Mod 2 = 0 Then rw.RowHeight = 5 End If Next rw End Sub （将偶数行的行高设置为 5，其中 mod 为求余函数）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 Next18 / 52 For Each rng In Sheet3.Range(&b2:d10&) If rng = && Then rn = rn & rng.Address & &,& Next Range(Left(rn, Len(rn) - 1)) = &未考& 字符） End Sub （left 函数返回从左开始取字符串中, Len(rn) C 1 长度个11：单元格的移动与复制'-----------------------------------------------------------'1.Range.Cut 方法 '将单元格区域剪切到指定的区域 '2.Range.Copy 方法 '将单元格区域复制到指定的区域 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 '注： '1.等号后的区域一定要加 value.否则不成功 '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, s19 / 52 m = Application.CountA(Columns(1)) For r = 1 To m / 2 Rows(r).Delete Next End Sub13：活动单元格与选择区域活动单元格：activecell,工作表中活动单元格只有一个 Sub activecells() a = activecell.Address Cells(2, 3).Activate End Sub 'selection 光标所选区域 Sub 光标所选区域() Selection = 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 的好处在于，可以很自由灵活选择你想要处理的单元格区域 （激活所选区域单元格） （光标所选区域的每一个单元格的值赋为 1） '取得活动单元格地址 '激活指定单元格14： UsedRange 已使用区域(条件统计)'Worksheet.UsedRange 属性 '返回一个 Range 对象，该对象表示指定工作表上所使用的区域 Sub 已使用区域() Sheet1.UsedRange.Select 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&, Cells(8, c)) c.FormulaArray = &=& & a & &+& & b End Sub 'usedrange 与 currentregion '如果表中只有一个区域，两者最后的结果是一样的 '只是表达方式不一样 Sub u 与 c() Sheet3.UsedRange.Select [a1].CurrentRegion.Select End Sub （此为一数组公式，formulaArray 为数组公式）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 Sub17：单元格的 resize 属性(单据数据保存)'Range.Resize 属性 '调整指定区域的大小。返回 Range 对象，该对象代表调整后的区域。 '语法 '表达式.Resize(行数, 列数) '表达式 Sub test() [a1].Resize(2, 3).Select [a1].Resize(2).Select [a1].Resize(, 3).Select End Sub Sub 保存() Dim i%, j%, k% i = [a1].CurrentRegion.Rows.Count - 1 j = [a1].CurrentRegion.Columns.Count k = Application.CountA(Sheet2.Columns(1)) [a2].Resize(i, j).Copy Sheet2.[a1].Offset(k) End Sub 一个返回 Range 对象的表达式。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 Sub19：定位条件'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 Selection.EntireRow.Delete Exit Sub 100: MsgBox &没有空行& End Sub20：find 查找方法'Range.Find 方法 '在区域中查找特定信息23 / 52 '语法 '表达式.Find(What, After, LookIn, LookAt, SearchOrder, SearchDirection, MatchCase, MatchByte, SearchFormat) '表达式 一个代表 Range 对象的变量。Sub 查找最后一个单元格() Set endrng = Cells.Find(&*&, , xlFormulas, , , xlPrevious) Range([a1], endrng).Select End Sub21：find 查找系统 'Sub 查询系统() ends = Columns(1).Find(&*&, , , , , searchdirection:=xlPrevious).Row '动态找到 A 列的最后一个单元 格 Range(&g3:l999&).Clear '清除之前所有的筛选结果 For Each Rng In Range(&a2:a& & ends)MatchByte TRUE:区分 m=m+1 （打勾） If Rng Like Range(&h1&) Then '如果条件成立，那么 FLASE:不区 k=k+1 分 （不打勾）Range(&a& & m + 1 & &:e& & m + 1).Copy Range(&g& & k + 2) '将记录复制到另一个区域 End IfNext End Sub22：进销存之入库单Sub 开单() Set es = Cells.Find(&*&, , xlFormulas, , , xlPrevious) 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: Set es = Cells.Find(&*&, , xlFormulas, , , xlPrevious)24 / 52 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(&*&, , xlFormulas, , , xlPrevious) For Each Rng In Range([c5], es) Rng.Offset(0, 2) = Rng.Offset(0, 1) * Rng Next End Sub23：单元格 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&, Cells(i, &n&)) = && '将最后付款月下的区域清空 For j = 2 To i k = Cells(j, &n&).End(xlToLeft).Column '找到最后付款月所在的列号 Cells(j, &n&) = Cells(1, k) '将对应的月份填入对应的单元格 Next j End Sub24：查找最后一个单元格的 N 种方法'这里讨论怎样找到最后一个单元格！ '不考虑最后量个单元格是：是公式，错误值，隐藏之类的特殊情况。 '以最后是一个常规的值为准。且以 A 列的最后一个单元格为准 '--------------------------------------------------------------Sub 最后的单元格() a = Cells(Rows.Count, 1).End(xlUp).Row 'end 属性 b = Columns(1).Find(&*&, , , , , xlPrevious).Row 'find 方法 c = Cells.SpecialCells(xlCellTypeLastCell).Row 'specialcells 方法 d = Sheet1.UsedRange.Rows.Count 'usedrange 属性 e = [a1].CurrentRegion.Rows.Count 'currentregion 属性 f = WorksheetFunction.CountA([a:a]) '工作表函数 counta25 / 52 g = Application.CountIf([a:a], &&&&) '工作表函数 countif End Sub25：单元格的合并'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 SubSub 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 Sub26：单元格的交集'Application.Intersect 方法 '返回一个 Range 对象，该对象表示两个或多个区域重叠的矩形区域。 Sub test() If Intersect([a1:d10], Selection) Is Nothing Then '注释： Is Nothing 用于判断对象是否存在， 对象可 以是工作簿，工作表，单元格区域等 MsgBox &没有交集& Else26 / 52 MsgBox Intersect([a1:d10], Selection).Address Intersect([a1:d10], Selection).Select End If End SubSub 隔行插入() For i = 0 To Application.CountA(Columns(1)) * 2 Step 2 Intersect([a1:d2].Offset(i), [a2:d3].Offset(i)).EntireRow.Insert Next End Sub27：单元格数字格式的设置代码'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(&*&, , xlFormulas, , , xlPrevious) 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 Sub28：单元格字体格式设置代码实现'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 Sub29：底纹颜色的设置'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 Cells(i + 1, 1).Interior.Color = QBColor(i)28 / 52 Cells(i + 1, 2) = i Next i End Sub Sub 三原色颜色值() Cells(2, 4).Interior.Color = RGB([a1], [b1], [c1]) End SubSub 直接颜色值() '此颜色有 255^3 种颜色 Cells(1, 1).Interior.Color = [b1] End Sub30：单元格格式设置实例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 i = Application.FindFormat.Interior.Color Set erng = Cells(Rows.Count, &e&).End(xlUp) For Each rng In Range([b2], erng) If rng.Interior.Color = i Then k = k + rng.Value: n = n + 1 Next （利用查找颜色的功能返回拾取的颜色）29 / 52 MsgBox &最后平均分为：& & k / n & &分& End 100: MsgBox &查找功能没有拾取到颜色！& End Sub32：粘贴Option Explicit 'Worksheet.Paste 方法 '将“剪贴板”中的内容粘贴到工作表上。 '表达式.Paste(Destination, Link) '表达式 一个代表 Worksheet 对象的变量。Sub 粘贴() Range(&B1:B6&).Copy Range(&c9&) Range(&B1:B6&).Copy End Sub '复制区域无公式 Sheet1.Paste Range(&c9&) '粘贴到 c4 单元格Sub 粘贴 2() Range(&c1:c6&).Copy End Sub '复制单元格有公式 Sheet3.Paste '如果不指定 Destination 参数，则在使用该方法之前必须选择目标区域。Sub 粘贴 1() Range(&c1:C6&).Copy Sheet3.Paste , True ' Application.CutCopyMode = True End Sub '复制 c1 单元格33：选择性粘贴Option Explicit 'Range.PasteSpecial 方法 '将 Range 从剪贴板粘贴到指定的区域中。 '语法 '表达式.PasteSpecial(Paste, Operation, SkipBlanks, Transpose) '表达式 一个代表 Range 对象的变量。30 / 52 Sub 选择怪粘贴() Range(&c2:c10&).Copy Range(&d2&).PasteSpecial 12 End SubSub 选择怪粘贴运算() 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 Sub31 / 52 34：合并单元格Option Explicit 'Range.Merge 方法 '由指定的 Range 对象创建合并单元格。Sub 合并单元格() Selection.Merge End SubSub 合并单元格实例() 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 Sub35：合并单元格实例与取消合并单元格'----------------------------------------------------------------------'Range.MergeArea 属性 '返回一个 Range 对象，该对象代表包含指定单元格的合并区域。 'Range.UnMerge 方法 '将合并区域分解为独立的单元格 '-------------------------------------------------------------------------Sub test() a = Range(&a1&).MergeArea.Count [a1].UnMerge End SubSub 解除合并单元格后保持原来的数据() Dim b%, rng As Range For Each rng In Selection b = rng.MergeArea.Count32 / 52 rng.UnMerge rng.Resize(b) = rng Next End Sub36：有条件的添加批注'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 If Rng &= 90 Then Rng.AddComment.Text &优秀& Next End Sub37：修改批注（注意文件地址的书写方式）'修改批注 Sub 修改批注() Range(&a2&).AddComment '添加批注 [a2].Comment.Shape.Height = 50 '设置批注高度 [a2].Comment.Shape.Width = 40 '设置批注宽度 [a2].Comment.Shape.Fill.UserPicture ThisWorkbook.Path & &\7pic\阿汤.png& End Sub Sub 批量将批注增加背景()33 / 52 For Each Rng In Selection paths = ThisWorkbook.Path & &\7pic\& & Rng.Value & &.png& Rng.ClearComments Rng.AddComment Rng.Comment.Shape.Height = 50 Rng.Comment.Shape.Width = 40 '设置批注宽度 Rng.Comment.Shape.Fill.UserPicture paths Next End Sub38：图形基础'Shapes 对象 '指定的工作表上的所有 Shape 对象的集合。 '说明 '每个 Shape 对象都代表绘图层中的一个对象，如自选图形、任意多边形、图片、图表等。Sub abc() Dim ob As Shape n = Sheet1.Shapes.Count 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 图形插入() Sheet3.Shapes.AddPicture ThisWorkbook.Path & &\7pic\林志玲.png&, _ True, True, 100, 100, 70, 70 End Sub Sub 图形删除() For Each shp In Sheet3.Shapes shp.Delete Next shp End Sub '图形名称 '图形类型 '顶端坐标 '左端坐标 '宽度 '高度39：图形的插入应用实例Sub 宏 1()34 / 52 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) Sheet1.Shapes.AddPicture i, True, True, rngs.Left, rngs.Top, rngs.Width, rngs.Height Next Rng End Sub40：多表合并'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 rs = st.UsedRange.Rows.Count ' 计算 1-3 月份每个表的最后一行 rss = zst.UsedRange.Rows.Count + 1 '计算“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 Sub41：多表拆分Sub 多表拆分() For f = 1 To 3 '循环三次（只拆分三个月） Worksheets.Add.Name = f & &月& '新建工作表，并以月份命名 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 Sub35 / 52 第四章：事件程序:1：事件程序定义与作用'1.定义 'excel 事件程序：因为一个操作(动作)而触发了一段程序。让程序发生了运行。 '就像机关设置'2.实例 '例 1：打开工作表 1，则运行一段程序（选择工作表 1 触发程序） '例 2：保护工作表数据实例。'3.作用 'excel 事件程序的作用：以前程序只能通过手工运行或指定宏功能来完成 '事件程序则可以却因不同的操作而自动触发运行不同的程序。 '4.代码位置 'excel 事件程序代码存放在位置 '----------------------------------'事件类型 代码位置 '----------------------------------'工作表事件 工作表 '工作簿事件 工作簿(thisworkbook) '程序事件 工作簿(thisworkbook)或类模块2：事件程序基础'代码存储位置 '事件 '------------------------------------------------------'应用程序-根据应用程序的动作进行控制 关事件 '工作簿-根据工作簿的动作进行控制 关事件 '工作表-根据工作表的动作进行控制 的相关事件 sheet1.sheet2.... 对工作表中所有单元操作 thisworkbook 对所有工作表操作的相 类模块或 thisworkbook 对所有工作簿操作的相 代码位置'2.括号里面是参数(传回值用法)36 / 52 '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 WorkbookPivotTableCloseCloseConnection WorkbookPivotTableOpenCloseConnection WorkbookRowsetCompletd Workbooksync 注释 当新建一个工作簿时发生此事件 当激活任何工作表时发生此事件 在双击任何工作表前发生此事件 右键单击任何工作表前发生此事件 在重新计算工作表时发生此事件 更改任何工作表的单元格时发生此事件 当工作表失去焦点时发生此事件（离开工作表时）。 在单击工作簿中的任何超链接时发生。 在更新数据透视表的工作表后发生。 所选内容在任何工作表上更改时发生。 在激活任何工作簿窗口时发生。 工作簿的窗口变为非活动状态时，将产生本事件。 改变工作簿窗口大小时发生 当激活任何工作簿时发生此事件 工作簿为加载宏安装时发生此事件 当任一工作簿作为卸载宏时发生 在保存或导出工作簿中的 XML 数据之后发生此事件 发生 关闭任何工作簿前发生此事件 在打印工作簿前发生此事件 在保存任何工作簿前发生引事件 保存或导出 XML 数据前发生的事件 发生 当打开的工作簿转为非活动状态时发生此事件 在任何打开的工作簿中新建工作表时发生此事件 当打开一个工作簿时发生此事件 在数据透视表的链接关闭之后发生此事件 在数据透视表的链接打开之后发生此事件 如果用户在 OLAP 数据透视表上深化记录集或调用行集操作，则会发生 WorkbookRowsetComplete 事件 此事件 37 / 52当刷新现有的 XML 数据链接或新的 XML 数据被导入任一打开的 Excel 工作簿之后时当刷新现有的 XML 数据链接或新的 XML 数据被导入任一打开的 Excel 工作簿之前时当作为“文档工作区”一部分的工作簿的本地副本与服务器上的副本进行同步时发生 工作簿事件 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 数据之后发生此事件 生此事件 是否保存更改之前产生。 在打印指定工作簿（或者其中的任何内容）之前，发生此事件 保存工作簿之前发生此事件 在 Excel 保存或导出指定工作簿中的 XML 数据之后发生此事件 生此事件 图表、工作表或工作簿被停用时发生此事件 当在工作簿中新建工作表时发生此事件 打开工作簿时，发生此事件 数据透视表关闭与其数据源的链接后发生此事件 数据透视表打开与其数据源的链接后发生此事件 如果用户在 OLAP 数据透视表上深化记录集或调用行集操作，则会引发此事件 当激活任何工作表时发生 此事件 当双击任何工作表时发生此事件，此事件先于默认的双击操作发生 右键单击任一工作表时发生此事件，此事件先于默认的右键单击操作 在重新计算工作表时或在图表上绘制更改的数据之生发生此事件 当用户或外部链接更改了任何工作表中的单元格时发生此事件 当任何工作表停用时发生此事件 单击 Excel 中的任何超链接时发生此事件 在数据透视表的工作表更新之后发生此事件 任一工作表的选定区域发生更改时，将发生此事件在刷新现有的 XML 数据链接或将新的 XML 数据导入到指定的 Excel 工作簿之后，发在关闭工作簿之前，先产生此事件。如果该工作簿已经更改过，则本事件在询问用户在刷新现有的 XML 数据链接或将新的 XML 数据导入到指定的 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 Sub4 工作表事件实例 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 Sub5：工作表事件实例（自动列出工作表名与单元格区域保护）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 Sub6：工作簿事件实例 1（自动选择月份表、右键禁用、打印控制）'事件中的 Cancel: ' 默认为 false，在完成事件内代码效果后，接着继续完成操作的后续效果。 ' 而为 true 时，在完成事件内代码效果后，终止当前操作的后续效果。 ' 相当于给用户控制事件提供一个开关。可以把用户自定义事件代替默认事件 ' 没有 Cancel 就是说不给你这个控制权限，一旦一始就要按流程结束。 Private Sub Workbook_Open() mon = Format(Now(), &m&) Sheets(mon & &月&).Select End SubPrivate Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean) Cancel = True '禁用右键 End SubPrivate Sub Workbook_BeforePrint(Cancel As Boolean) If Month(Now()) & &月& && ActiveSheet.Name Then MsgBox &不能打印& Cancel = True Else MsgBox &能打印&40 / 52 Cancel = False End If End Sub7：工作簿事件实例 2（给工作表加密码）'Application.EnableEvents 属性 'Application.EnableEvents = True/FALSE '如果对指定对象启用事件，则该属性值为 True。Boolean 类型，可读写。 '作用：临时关闭，防止死循环 'Private Sub Workbook_Open() 'Application.EnableEvents = True 'Sheet2.Cells.Font.Color = RGB(255, 255, 255) 'Sheet3.Activate 'End Sub Private Sub Worksheet_Activate() '激活工作表触发的程序 a = InputBox(&请输入密码&) If a = 123 Then Cells.Font.Color = RGB(0, 0, 0) Application.EnableEvents = False Else Sheet3.Activate End If End Sub8：应用程序事件'应用程序事件：是对每个打开工作簿操因操作所发生的事件程序 '应用程序事件代码位置：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 文件中。例子：任何时候都不能增加工作表 Private Sub excelapp_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) '4-8 课内9：应用程序事件实例41 / 52 容 Application.StatusBar = &选择区域是：& & Target.Address(0, 0) '任意工作表显示选择区域地址 End SubPrivate 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 Sub10：事件总结1.各种事件的作用范围 工作表：作用于某个工作表下的所有单元格操作 工作簿：作用于某个工作簿下的所有工作表 应用程序:作用于所有工作簿。 2.各种事件过程代码的执行顺序 工作表事件→工作薄事件→应用程序事件42 / 52 第五章：VBA 数组1：数组基础' ' ' ' ' ' ' ' ' ' ' ' ' ' ' Sub test2() Dim arr1(3) Dim arr2(1 To 3) Dim arr3(1 To 3, 1 To 2) Dim arr4(3, 2) End Sub 5.当我们学会了数组，会发现以前的写的很多代码可以从数组的角度重写 3.数组特点 a.读写速度快（从内存读取数据要比从硬盘读取快） b.无法永远保存(内存只是暂存空间) 4.数组分类 a.一般分为：常量数组，静态数组，动态数组 b.如按维度为：1 维，2 维，3 维......60 维 2.数组位置 数组存储在内存中. 1.数组概念 数组就是一个列表或者一组数据表.2：数组维度' ' ' ' Sub test1() arr1 = [{&A&,&B&,&C&,&D&}] arr2 = Application.Transpose([{1;2;3;4}]) End Sub Sub test2() arr3 = [{&张&,1;&王&,2;&陈&,3;&李&,4;&林&,5}] End Sub Sub test4() arr = Array(1, 2, 3, 4) arr1 = Array(Array(&a&, &b&), Array(1, 2, 3)) 【转置】 数组最多有 60 维，但在 excel 中一般最到 2 维 1.excel 中的一行或一列可以转换 1 维数组 2.excel 中的多行多列可以转换成 2 维数组43 / 52 End Sub3 向数组中写数据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&, &B&, &A&, 9) End Sub Sub 单元格区域数据批量写入数组() arr = Application.Transpose([a1:a4]) '注意：当向数组中批量写入多行，结果就是二维数组 arr1 = Application.Transpose(Application.Transpose([a7:d7])) End Sub4:在数组中取数据'怎样在数组中取数 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] arr1 = Application.Transpose(arr) [a7:d7] = arr1 [a8:c8] = arr1 [a9:e9] = arr144 / 52 '注意左右两边尺寸的对应 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 Sub6：数组写入与读取实例(数组的优势体现)'比比哪个程序的运行速度更快 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 Dim arr1(1 To 5000, 1 To 1) Set Rng = Cells(Rows.Count, 1).End(xlUp) arr = Range([a1], Rng) '数组写入 For Each a In arr45 / 52 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 Sub7：数组应用之计算不重复值'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 SubSub 利用数组提取不重复值() Dim arr1(1 To 10) Set lastcell = Cells(Rows.Count, &b&).End(xlUp) '查找最后 B 列最后一个非空单元格 arr = Range([b2], lastcell) For i = 1 To lastcell.Row - 1 For j = 1 To UBound(arr1) If arr(i, 1) = arr1(j) Then GoTo 100 End If Next j k=k+1 100: Next i [e2].Resize(k) = Application.Transpose(arr1) End Sub '循环结束后将 arr1 的结果赋值给单元格区域 '做个计数器，计算相等重复的元素人数 arr1(k) = arr(i, 1) '如果循环完后都没有相等的，则将 arr1 循环的元素赋值给 arr1 数组 'arr 数组元素与 arr1 元素循环对比，如果相等，则跳出内层循环 '将 B 列的姓名数据赋值给变量 arr 形成一个数组 '循环 B 列单元格个数的次数 '找到 arr1 数组的最大小标，形成循环x = arr(i, 1): y = arr1(j) '辅助代码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 形成一个数组46 / 52 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 Sub9：动态数组（条件筛选）'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&, rn) m = WorksheetFunction.CountIf(Range(&a2&, rn), &&=80&) '确定重新定义数组的上界【工作表函数】 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) End Sub 【定位最后一行】10：动态数组(多表合并)'Preserve 可选的。关键字，当改变原有数组最末维的大小时，使用此关键字可以保持数组中原 来的数据。 Sub abc() Dim arr() i=9 arr = [{1,2,3}]47 / 52 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 '目的：只有&汇总&工作表的数据不合并 ' 将各表的数据循环写入 arr1 c = sh.Name & &!& & sh.Range(&a2:b& & sh.UsedRange.Rows.Count).Address '帮助代码 arr1 = sh.Range(&a2:b& & sh.UsedRange.Rows.Count) 数组中 act = act + UBound(arr1) '累加各表数据的行数，作为重新声明 arr1 数组的上界 '重新声明数组 arr ReDim Preserve arr(1 To 2, 1 To act) 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 Sub11： 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 Sub 数据互换() arr = [a1].CurrentRegion For Each a In arr arr1 = Split(a, &-&) n=n+1 Cells(n, &c&) = arr1(1) & &-& & arr1(0) Next End Sub 【以 A1 单元格为扩展的单元格】12： Join 函数与数组（数组生成字符串）48 / 52 'Join 函数(作用于 1 维数组) '返回一个字符串，该字符串是通过连接某个数组中的多个子字符串而创建的。 'Join(数组,&连接符&)Sub test() arr = [{1,2,3,4}] i = Join(arr, &-&) End SubSub 数据合并() 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&,&bb&,&c&,&ba&,&dd&,&nba&}] a = Filter(arr, &b&, True) b = Filter(arr, &b&, 0) End SubSub 筛选() [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)49 / 52 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 Sub14：工作表函数与 VBA 数组(几句代码制作查询系统)'在工作表支持数组的函数，很多也支持 VBA 数组 '返回结果，当然也是一个数组 '如 sumif,countif,match,index,vlookup..... '工作表函数 INDEX 处理 VBA 数组 '如对 INDEX 函数不了解：请移驾自学网：http://www.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&, Cells(Rows.Count, &g&).End(xlUp)) 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) End If Next End Sub15:借助 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&)50 / 52 n=n+1 If n = 1 Then Set rngs = Rng Else Set rngs = Union(rngs, Rng) k = rngs.Address End If Next rngs.Interior.ColorIndex = 3 End Sub16:利用 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 Sub17: 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 arr1(1, n) = arr(i, 1) arr1(2, n) = arr(i, 3) 100: Next [e2].Resize(n, 2) = Application.Transpose(arr1) End Sub51 / 52 第六章：VBA 与字典技术52 / 52
VBA学习笔记系列---ExcelVBA 基础 - 1. 更改日期显示方式: 2. 公式应用:可以先设定一个单元格,其他进行自动填充。 3. 常用函数 3.1 数学与三角函数 3.1.1...VBA学习-控件-笔记-2016_电脑基础知识_IT/计算机_专业资料。excel VBA控件学习笔记2013版office EXCEL2013 版,EXCEL 学习 1 注:Ctrl+鼠标左键(打开目录链接) P21...VBA学习笔记 - Sub sss() Select Case Range(B1).Value Case Is = 1 MsgBox 1 代表入门 Case 2 MsgBox (2 代表基础) ...VBA学习笔记系列---VBA高级技术 - 1. Excel 打开 xml 文件: 在 Excel 中打开的效果如下: 现在我们在 Excel 中添加一条记录: 然后全部选中,右键:xm...Excel VBA 学习笔记 - 1. Excel 2010 可以运行宏但不能编辑啊? If 函数 2. 录制宏 你做什么他做什么。 Sub 生成工资条() Dim i As Long...VBA 学习笔记 - VBA 常用代码中英文对照 Range:单元格 CopyFromRecordset:拷贝 来自 记录集 Execute(sq1):执行 SQL Set rst = Noth...VBA 学习第七课笔记和代码: 一、 知识点: 1、'Range 表现单元格对象的第二种方法 'Range(起始单元格,终止单元格) 是以起始单元格为左上角,终止单元格为右...VBA自已学习笔记 - MsgBox Workbooks.Count 这是统计打开工作薄的数量 Workbooks 后再输入个点(.),就会出现一个下拉框,框中的带小手指的就是工作薄集合的属 性...VBA学习笔记系列---WorkBookworksheetsRange对象 - 1.在 Microsoft Excel 对象模型中, Workbook 对象表示一个 Excel.xls 工作 ...VBA学习笔记系列---VBA... 5页 1下载券 VBA 学习笔记 12页 2下载券 VBA...VBA 总共支持 13 种数据类型, 对象型是其中一种, 包括 application, workbook,...
All rights reserved Powered by
www.tceic.com
copyright ©right 。文档资料库内容来自网络，如有侵犯请联系客服。}
我要回帖
更多关于 单击某个单元格,然后重新粘贴 的文章
更多推荐
- ·龙腾世纪的推荐配置对处理器有玩大型网游什么配置的电脑要求？
- ·目前考虑购买复古木质做音箱用什么木材最好，ALATS和马歇尔哪个品牌更适合中国家庭？
- ·FC24这是什么意思怎么是两个控制器故障代码如何还原？
- ·那种直播间字幕怎么弄烟花改字的视频怎么弄？
- ·立创广场商城最近有什么大活动吗？
- ·我爱上我大姑姐家孩子喜欢来我屋、拿东西了，真心的喜欢她真的，我爱上她了，帮我吧，怎样的池个微信上说要她感动
- ·有人用过z1i的电信写号苹果4还原一直在转圈版吗
- ·2010珍珠控台配接电脑灯不能存灯了！调好的灯就是存不上有哪个大师知道是什么原因么？
- ·djkz13520的时光密码歌词是多少
- ·2018年制作高清视频的2018美工组装电脑配置置，要求必须是套装机，大概五千至1万价位的，请各位大神多发几套配置来看看
- ·求狂暴南方巨兽龙百度云资源!!!!公众号别来了。
- ·求韩国电影 老师的秘密韩国电影伦理片百度云
- ·山西一家三代人种子带。谢谢。
- ·那里有可虚拟定位软件
- ·多多小说可以用看小说赚钱的软件是微信提现的吗？
- ·大家房价还会涨吗关注我么
- ·淮北爱上汽摩频道购物网站站的注意了，最近已有多人被骗
- ·删微信 伤自尊被自尊和封建的封印了，三，然后解除怎么能。成功？打开删微信 伤自尊呢
- ·2018年制作高清视频的地下城工作室电脑配置置，要求必须是套装机，大概五千至1万价位的，请各位大神多发几套配置来看看
- ·有没有杜文泽走老去台湾的36D豪情，百度云资源，跪求
- ·VBA中用单元格被单击单击事件来模拟超级链接的效果
- ·想看/黑镜背景墙/ 谁知道看美剧的网站
- ·请问哪个号码比较好 156……5543什么意思 186……7769 156……8210
- ·支付宝身份验证怎么办是什么意思
- ·下一界世界杯世界杯第一界是什么时候候——www.ip5058.com
- ·小鹏汽车怎么样云盒为什么点不了变音，出来悬浮窗，但是点悬浮窗没用，长按就没了
- ·可以通过绝地求生刺激战场怎么删除微信好友ID查找到微信吗？
- ·微信小程序名称抢注审核不通过怎么办？
- ·前女朋友把QQ微信怎么添加QQ好友都删除了，代表什么？
- ·谷歌浏览器手机浏览器删除了历史记录怎么找回凭空消失
- ·人人快借微信公众号
- ·我删了女朋友微信,她发微信朋友圈公布女朋友说:以为努力就会有结果 结果聚散不由我 什么意思
- ·怎么查我12306的信息泄露在派出所备案了信息泄露在派出所备案了怎么办
- ·我的众人帮支付宝提现多久为什么最近提现不了,最近天天都显示这个我晚上12点起来提现都是显示这个。好几天了
