佛山小老鼠说Excel VBA

佛山小老鼠 · 发表于 2012-11-3 01:28

本帖最后由佛山小老鼠于 2012-11-8 10:44 编辑

第八讲工作簿对象

一. 工作簿的引用方式

1. 以名称引用

(1).实例

Sub test2() ' 把“汇总”工作簿打开
MsgBox Workbooks("汇总.xlsm").Worksheets(1).Range("A1")
End Sub

复制代码

2. 以索号引用

(1).实例

Sub test1()
MsgBox Workbooks(1).Name
End Sub

复制代码

3. Thiswokbook 表示代码所在的的工作簿

(1).实例

Sub test3()
MsgBox ThisWorkbook.Name
End Sub

复制代码

(2).11

4. Activeworkbook 表示当前活动工作簿

(1).实例

Sub test4()
MsgBox ActiveWorkbook.Name
End Sub

复制代码

二. 保存工作簿

1. 另存为的方法

(1).实例在桌面上新建一个工作簿，取名为“汇总”，且工作簿密码是1234

Sub test1()
Dim wb As Workbook '定义wb工作簿型对象变量
Set wb = Workbooks.Add '把新建的工作簿赋给wb
With wb '处理工作簿wb
.SaveAs Filename:="D:\我的文档\桌面\汇总.xlsx" '另存为桌面，取名为“汇总”
.Password = "1234" '给工作簿 wb设置密码为1234
End With '结束处理
End Sub

复制代码

三. 打开工作簿

1. 用Open方法，它的参数有许多，我现在只用了第一个参数：要打开的工作簿所在的路径，其它参数没有，可以自己去看帮助。

(1).实例打开“F第八讲VBA对象”文件中的“汇总”工作簿

Sub test1()
Workbooks.Open Filename:=ThisWorkbook.Path & "\汇总.xlsm"
End Sub

复制代码

四. 从不打开的工作簿里提取数据

1. 实例

Sub Test1()
Dim Wb As Workbook '定义Wb为工作簿对象型变量
Dim MyPth As String '定义MyPth为文本型变量
Application.ScreenUpdating = False '关闭屏幕刷新
MyPth = ThisWorkbook.Path & "\数据源.xlsx" '把数据源工作簿路径赋给MyPth
Set Wb = GetObject(MyPth) '把返回路径上的文件引用且赋值给Wb
With Wb.Sheets(1).Range("A1").CurrentRegion 'Wb工作簿里工作表1和A1单元格相连的区域
Range("A1").Resize(.Rows.Count, .Columns.Count) = .Value '把Wb工作簿里的工作表1数据写于活动工作表里以A1单元格为区域
'Rows.Count是2^20行,Columns.Count2^14列,它们的对象是 Wb.Sheets(1).Range("A1").CurrentRegion，也就是起到复制整个工作表的作用
Wb.Close False '关才Wb工作簿，且不保存更改
End With '
Set Wb = Nothing '释放内存
Application.ScreenUpdating = True '打开屏幕刷新
End Sub

复制代码

佛山小老鼠 · 发表于 2012-11-3 01:30

本帖最后由佛山小老鼠于 2012-11-8 10:45 编辑

第九讲事件

一. 事件分类

(1).应用程序事件经常在类模块中定义这种事件

(2).工作簿事件如工作簿的Open事件，一打开工作簿就就执行过程

Private Sub Workbook_Open()

……

End Sub

实例一开工作作簿就问好

Private Sub Workbook_Open()
MsgBox "佛山小老鼠你好！"
End Sub

复制代码

(3).工作表事件如工作表里的Change事件，一改变工作表单元里的内容就触发，工作表事件用的比较多

a. Private Sub Worksheet_Change(ByVal Target As Range)，一改变单元格内容就触发

……

End Sub

b. Private Sub Worksheet_SelectionChange(ByVal Target As Range)一选择就触发

……

End Sub

实例一防止看错行

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Myrow As Integer '定义变量Integer为整型数据类型
Myrow = Target.Row 'Target当前活动单元格，取得其行号
Cells.Interior.ColorIndex = xlNone '把整个工作表的底纹设置为无，目的是为了删除上一次的
Rows(Myrow).EntireRow.Interior.ColorIndex = 8 '给Myrow这一整行添加底纹
End Sub

复制代码

实例二自动补齐卡号，由于卡号前面的是一样，只是后面的不一样，便不能用单元格格式设置

Private Sub Worksheet_Change(ByVal Target As Range) '工作表事件，一改变内容就发生
If Target.Column = 1 Then '如果活动单元格的列号是等于1，那么
If Target.Count <> 1 Then Exit Sub '又如果选中的不只是一个单元格，那么就退出运行
MyTart = Target.Value '把活动单元格的值赋给MyTarg
Application.EnableEvents = False '关闭联动事件
Target = "'" & "6210260500059330" & MyTart '在原来数据前面加6210260500059330
MyTart = "" '把变量MyTart清空
Application.EnableEvents = True '打开联动事件
End If
Columns("A:A").EntireColumn.AutoFit 'A列自动适合列宽
End Sub

复制代码

实例三在B列任意单元格输入任何文本后，A列与其所对应的单元格自动显示出当天的日期

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 2 Then '如果当前单元格的列号2
If Target.Offset(0, -1) = "" And Target <> "" Then '又如果A列对应的单元不为空且活动单元也不为空，那么
Target.Offset(0, -1) = Date '在A列对应的单元格输入当前日期
End If
End If
Columns(1).AutoFit 'A列自动适合列宽
End Sub

复制代码

(4).其它事件

a. OnTime事件

表达式 Application.OnTime 开始时间, 过程名结束时间布尔值

解释如果省略第三参数，开始时间就是过程运行时间，如果没有省略，那第三参数就是过程运行时间，第四参数如果是False就是停止OnTime事件

实例在A1单元格显示当前的时间且带有秒数的格式

Sub Mystar()
Range("A1") = Format(Now, "hh:mm:ss") '在A1单元格写于时间，用了Format函数，格式用时分秒
Application.OnTime Now + TimeValue("00:00:01"), "Mystar" '在原有的时间加一秒执行
End Sub
Sub MyStop()
On Error Resume Next '为什么要加一句防错语句，因为先前当没有执行Mystar过程，就会报错
Application.OnTime Now + TimeValue("00:00:01"), "Mystar", , False '记得是第四个参数用了False,所以它前面还有二个逗号
End Sub

复制代码

b. OnKey事件

1. 表达式 Application.OnKey 快捷键, 过程名

a. 一些常用控制键的代码 Ctrl ^ Shift + Alt % ，其它的键要加{}，而26个字母不要加，如Ctrl+D这样表示"^d"；再加Shift+F1这样表示"+{F1}"

b. 实例按快键Ctrl+F9，输入当天的星期

在普通模块里输入

Sub 输入星期()
Selection = Format(Now, "AAAA")
End Sub
Sub 打开快捷键()
Application.OnKey "^{F9}", "输入星期"
End Sub
Sub 关闭快捷键()
Application.OnKey "^{F9}", ""
End Sub

复制代码

在工作簿模块里输入

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call 关闭快捷键
End Sub
Private Sub Workbook_Open()
Call 打开快捷键
End Sub

复制代码

佛山小老鼠 · 发表于 2012-11-3 01:41

本帖最后由佛山小老鼠于 2012-11-8 10:47 编辑

第十讲窗体与控件

如果要编辑稍大一点的程序，大家就要用到窗体和控件了，其实也就是我们平常所说的对话框，达到人机对接，下面我们来一一讲解它们

一、窗体

1、新建窗体

A、 Alt+F11——>>打开VBE编辑器——>>插入菜单——>>窗体

B、把光标定位到“资源管理器”处——>>右击——>>插入——>>用户窗体

2、删除窗体

A、把光标定位到资源管理器上——>>右击——>>移除窗体

3、窗体的Caption属性，是显示在窗体的标题

A、实例加载时修改窗体的标题为“身份证”,把光标定位到窗体上——>>右击——>>查看代码——>>对象列表选择窗体名称UserForm1——>>过程列表中选择Initialize如图 18，输入以下代码

Private Sub UserForm_Initialize()
UserForm1.Caption = "车模"
End Sub

复制代码

然后新建一个普通的模块里输入

Sub test()
UserForm1.Show 0 '运行窗体，当Show后面是0是，表示窗体打开之后还可以操作工作表
'如果省略的化或者为1的化，表示窗体打开之后就不能再操作工作表了，如果要操作就要关闭窗体
End Sub

复制代码

图 18

4、修改窗体的名称

A、 Alt+F11——>>视图菜单——>>属性窗口，也可以按快捷键F4——>>名称——>>输入“异同项”，效果如图 19

图 19

5、显示窗体

A、窗体名称 .Show 0

后面用0还是用1在上面我已讲过，这里不再啰嗦了

6、关闭窗体

A、 Unload.窗体名称

如果在窗体模块里也可以用me来代替窗体名称

7、在窗体中添加按钮（各按钮如所图 20示

图 20

A、标签 Label

B、文本框 TextBox

C、命令按钮 CommandButton

D、图像控件 Image

E、复选框 CheckBox

F、切换按钮 ToggleButton

实例仿制一个QQ登录界面，如图图 21

图 21

G、组合框 ComboBox

1. 可以输入文字相当于文本框的作用，且还有列表框的作用，也就是组合框集文本框和列表框特点一起

2. 给组合框添加数据

实例添加一个月份组合框

Private Sub UserForm_Initialize()
Dim i As Byte
For i = 1 To 12
Me.ComboBox1.AddItem i & "月"
Next i
Me.ComboBox1.ListIndex = 0
End Sub

复制代码

3. 单个读取 Me.ComboBox1.Value

H、列表框 ListBox

1. 只能选择，不能输入

2. 给列表框添加数据

实例添加一个月份列表框

Private Sub UserForm_Initialize()
Dim i As Byte
For i = 1 To 12
Me.ListBox1.AddItem i & "月"
Next i
Me.ListBox1.ListIndex = 0
End Sub

复制代码

3. 单个读取列表框中的值

Private Sub CommandButton1_Click()
MsgBox Me.ListBox1.Value
End Sub

复制代码

I、框架 Frame

J、选项卡控件 TabStrip

K、多页控件 MultiPage

L、滚动条 ScrollBar

M、数值调节按钮 SpinButton

N、单选按钮 OptionButton

O、 RefEdit控件

主要用来选择区域，当然我们也可以inputbox选区域，不过没有那么方便，RefEdit控件在Excel里选区域显得更专业一点，不过Vb里没有这个控件，不知为什么？

实例批量上下标

Private Sub CommandButton1_Click()
Dim MyRg As Range '定义变量
If Me.OptionButton1 = True Then '如果单选按钮1被选中，那么
For Each MyRg In Application.Intersect(ActiveSheet.UsedRange, Range(Me.RefEdit1.Value)) '遍历选中的所有单元格
'Intersect的作用是选中区域和有数据区域交集，这样就不用循环选中的每一个单元格，大大提高运行速度
'Me.RefEdit1.Value取出RefEdit1的值，作为Range的参数
MyRg.Characters(Start:=Len(MyRg) - Me.ComboBox1.Value + 1, Length:=Me.ComboBox1.Value).Font.Superscript = True
'上面这段代码大家可以通过录制得到，然后修改一下得到。代码的意思，把后面Me.ComboBox1.Value个字标示上标
'ComboBox1.Value是组合框的值，也就是说标示后面多少个，由它决定的。下面的代码也是这个意思，我就不多作解释了
Next MyRg
ElseIf Me.OptionButton2 = True Then
For Each MyRg In Application.Intersect(ActiveSheet.UsedRange, Range(Me.RefEdit1.Value))
MyRg.Characters(Start:=Len(MyRg) - Me.ComboBox1.Value + 1, Length:=Me.ComboBox1.Value).Font.Subscript = True
Next MyRg
Else
For Each MyRg In Application.Intersect(ActiveSheet.UsedRange, Range(Me.RefEdit1.Value))
With MyRg.Font
.Superscript = False '取消上标
.Subscript = False '取消下标
End With
Next
End If
End Sub
Private Sub CommandButton2_Click()
End '退出
End Sub
Private Sub RefEdit1_Change()
TextBox1.Text = RefEdit1.Value '当RefEdit1.Value选完后，直接把它的值赋给文本框1，其实这个代码没有作用，便于显示出来，看选区
End Sub

复制代码

Private Sub UserForm_Initialize() '加载窗体时
Dim i As Byte '定义变量
Me.OptionButton1.Value = 1 '加载窗体时把第一个单选按钮设置为默认的
For i = 1 To 5
Me.ComboBox1.AddItem i '给组合框赋值1，2，3，4，5
Next
Me.ComboBox1.ListIndex = 0 '让1显示为组合框的默认值
End Sub
Sub test()
Myf1.Show 1 '显示窗体
End Sub

复制代码

最后的效果图如图 22

图 22

佛山小老鼠 · 发表于 2012-11-3 01:44

本帖最后由佛山小老鼠于 2012-11-8 10:48 编辑

第十一讲用窗体与控件开发隐藏工作表工具

这一讲，相对前面来说，有一定的难度了，但是大家也要明白，你总有一天要步入这个程序开发中，如果你没有达到这一步，也就是总是VBA的门外汉，所以大家要坚持，不要退缩，其实那时学的时候也和你们一样，也放弃过，就是现在我还是有太多太多的不明白，看到一些高手写的程序，只要你天天学习，不放弃，那么你不懂就少一些，呵呵。说了一大堆话，老师也是为大家打打气，坚持，加油。

开发批量隐藏工作表工具的方法与步骤

一. 插入窗体与添加控件

二. 编写代码（因为代码后面都有解释，我这里就不多说了）

1. 普通模块里的代码

Sub test()
隐藏工具.Show 1 '打开隐藏工作表工具
End Sub

复制代码

Sub auto_open() '一打开工作簿就执行下面的代码如图24所示
MsgBox "记得打开---隐藏工作表工具的快捷是Ctrl+D" & Chr(10) & "佛山小老鼠提醒你，不要忘记了！", 64, "温馨提示"
'Chr(10)是换行
Call 打开快捷键 '呼叫“打开快捷”过程，然后运行它
End Sub

复制代码

Sub 打开快捷键()
Application.OnKey "^d", "test" '记得一定要小写字母，且不要加大括号，快捷键Ctrl+D执行test过程
End Sub

复制代码

Sub 关闭快捷键()
Application.OnKey "^d", "" '记得一定要小写字母，且不要加大括号，把关联的过程名为空就删除了
'为了让其自动关闭，用了工作簿关闭事件，当然打开快捷键也就可以放在工作簿打开事件里
End Sub

复制代码

2. 窗体模块里代码

Private Sub CommandButton1_Click() '执行隐藏
Dim i As Integer, k As Integer, s As Integer '定义变量
For k = 0 To Me.ListBox1.ListCount - 1 '遍历列表框中的所有成员
If Me.ListBox1.Selected(k) = True Then '判断列表框中那一行是选中的，如果有，那么
s = s + 1 '累加S 目的为了在后面判断是不是所有的工作表是否被选中
End If
Next k
If Sheets.Count = s Then MsgBox "不能删除所有工作表，只少要留一张可见工作表": Exit Sub
'如果所有的工作表被选中，因为隐藏至少要保留一张，那么就结束程序
If Me.OptionButton1.Value = True Then '如果单选按钮1被选中，那么就要执行一般隐藏
For i = 0 To Me.ListBox1.ListCount - 1 '遍历列表框所有成员
If Me.ListBox1.Selected(i) = True Then '如果被选中
Worksheets(Me.ListBox1.List(i)).Visible = 0 '那么相对应的工作表就要一般隐藏，Me.ListBox1.List(i)得到是工作表名
End If '
Next i '
Else '否则就执行下面的代码
For i = 0 To Me.ListBox1.ListCount - 1 ''遍历列表框所有成员
If Me.ListBox1.Selected(i) = True Then '如果被选中'
Worksheets(Me.ListBox1.List(i)).Visible = xlSheetVeryHidden ''那么相对应的工作表就要深度隐藏
End If '
Next i '
End If
End Sub
Private Sub CommandButton2_Click() '显示
Dim i As Integer '定义变量
For i = 0 To Me.ListBox1.ListCount - 1 '遍历列表框所有成员
If Me.ListBox1.Selected(i) = True Then ''如果被选中'
Worksheets(Me.ListBox1.List(i)).Visible = 1 '那么相对应的工作表就要显示
End If '
Next i '
End Sub
Private Sub CommandButton3_Click() '全选
Dim i As Integer '定义变量
For i = 0 To Me.ListBox1.ListCount - 1 '遍历列表框里所有成员
Me.ListBox1.Selected(i) = True '把一个一个依次选中，Selected(i) = True是表示选中，反之为False是不选中
Next i
End Sub
Private Sub CommandButton4_Click() '反选
Dim i As Integer '定义变量
For i = 0 To Me.ListBox1.ListCount - 1 '遍历列表框里所有成员
If Me.ListBox1.Selected(i) = True Then '如果被选中''
Me.ListBox1.Selected(i) = False '取消选中
Else '否则，如果没有被选中的，那么
Me.ListBox1.Selected(i) = True '被选中
End If
Next i '
End Sub
Private Sub UserForm_Initialize() '窗体加载时
Dim i As Integer, Mycount As Integer '定义变量
Mycount = Sheets.Count '统计工作簿里有多少个工作表，且把值赋给Mycount
For i = 1 To Mycount '遍历所有工作表
Me.ListBox1.AddItem Sheets(i).Name '把工作表名一一加载到列表框中
Next i '
Me.ListBox1.MultiSelect = 1 'MultiSelect = 2 表示可以借助控件键Shift Ctrl进行多选，
'MultiSelect = 0 表示只能选选择一行。'MultiSelect = 1也能选多行，但是不能配合着Ctrl和Shift键进行多选
Me.OptionButton1.Value = True '使单元按钮1为默认值
Me.ListBox1.Selected(0) = True '使列表框中的第一个被选中
End Sub

复制代码

三. 批量隐藏工作表的效果图如23

图 23 图 24

佛山小老鼠 · 发表于 2012-11-3 01:47

本帖最后由佛山小老鼠于 2012-11-8 10:51 编辑

第十二讲自定义函数

一. 为什么要自定义函数（Function过程）

一说到函数，大家都说会Excel博大精深，确是，可以给我们工作上带来许多方便，Excel本身的函数有几百个了，那我们为什么还要自定义函数呢？

1. 简化求解过程，用其它公式做出来公式长且复杂

2. 弥补Excel内置函数的不足

二. 创建自定义函数过程

1. 方法一 Alt+F11——>>插入模块——>>插入过程——>>类型——>>函数。结果如图图 25

图 25

2. 方法二手动输入

Function 函数名()

……

End Function

三. 自定义函数实例

1. 自定义提取活动工作表名的函数

Function 提取活动工作表名() '函数名是"提取活动工作表名"
Application.Volatile '声明为易失性函数
提取活动工作表名 = ActiveSheet.Name '把活动工作表赋值给函数名"提取活动工作表名"
End Function

复制代码

2. 自定义提取工作表名函数

Public Function 提取工作表名(i As Integer) '提取工作表名为中文函数名
Application.Volatile '声明为易失性函数
If i <= Sheets.Count Then '条件，不能让i的值超过工作表数目，如果超过就显示为空
提取工作表名 = Sheets(i).Name '按位置顺序把工作表名依次赋给函数名“提取工作表名”
Else '
提取工作表名 = "" '
End If
End Function

复制代码

3. 自定义按颜色求和函数

Public Function SumColor(MyRg As Range, Col As Range) '定义函数名为SumColor
Dim rg As Range, S As Long '定义相关的变量
Application.Volatile '声明为易失性函数
ColIndex = Col.Interior.ColorIndex '提取单元格Col的底纹颜色值赋值给ColIndex
For Each rg In Application.Intersect(ActiveSheet.UsedRange, MyRg) '遍历参数MyRg里的有数据区域
If rg.Interior.ColorIndex = ColIndex Then '如果MyRg区域里的单元格有底纹颜色和CoIdndex相同的，那么
S = S + rg.Value '单元格Rg的值到累加到S上
End If '
Next rg '
SumColor = S '最后把S的值赋给函数SumColor
End Function

复制代码

四. VBA中调用工作表函数

1. 在VBA中调用工作表函数需要在工作表函数前加上WorksheetFunction属性。应用于Application对象的WorksheetFunction属性返回WorksheetFunction对象，作为VBA中调用工作表函数的容器，在实际应用中可省略Application对象

2. 完整的表达式：Application.WorksheetFunction.工作表函数名

3. 要注意的是，函数参数一定要用VBA里引用方式

4. 实例标示重复值

Private Sub CommandButton1_Click()
Dim Myarray As Range, mgr As Range, i As Integer '定义相关的变量
If RefEdit1.Value = "" Then MsgBox "请选择你要标示的区域", vbCritical, "佛山小老鼠提醒": Exit Sub
'如果控件RefEdit1没有选择区域，那么就退出，且提示，注意一行简写形式，你记住就可以了
'vbCritical你也可以改为数值16，显示警告的图标
Set Myarray = Range(RefEdit1) '把控件的选区赋给Myarray,因为是对象，所以用了Set,另外把控件RefEdit1选区转为单元格，一定要在前面加Range
Myarray.ClearFormats '清除选区原有颜色，目的是区分为了再标示，如果不清除如果原有字体也有红色，那样就和结果混了
For Each mgr In Application.Intersect(ActiveSheet.UsedRange, Myarray) '遍历选区有数据的单元格
'Intersect(ActiveSheet.UsedRange, Myarray)这一句，我不再多解释了，目的了防止整行整列选中，导致程序被卡死。
If Application.WorksheetFunction.CountIf(Myarray, mgr) > 1 Then '这一句就是举个例子的目的
'我们可以引用工作表里的内置函数，不过要注意的用法，单元格，单元格区域的引用方式。如果有重复
mgr.Font.ColorIndex = 3 '字体的颜色为红色
End If
Next mgr '
Unload Me '关闭窗体
End Sub
Private Sub CommandButton2_Click()
Unload Me ''关闭窗体
End Sub

复制代码

佛山小老鼠 · 发表于 2012-11-3 01:50

本帖最后由佛山小老鼠于 2012-11-8 10:54 编辑

第十三讲 VBA数组基础（一）

一. 什么是数组？

VBA数组就是储存一组数据的数据空间，它是由连续可索引的且具有相同的数据类型成员集合。数组中的每一个成员都具有唯一的索引号，数组存在于内存中，平常我们是把数据存在于工作表中的单元格里。

二. 数组的特点

1. 读写速度快

学VBA的朋友，刚开始时，不会怎么要求关注运行速度，但是当你处理大量数据时，当你的VBA水平不断提高时，可能你就有这方面的意识了，Vba读取内存中的数据远远比从读取对象中的数据要快，有了这个特点，往往VBA爱好者一有机会就会用数组处理数据。

(1).实例对比下面两段代码的运行速度

Sub test1() '用时0.12秒
Dim t As Single, i As Integer, s As Long, arr As Variant
t = Timer
arr = Range("A1:A1000000")
For i = 1 To 5000
s = s + arr(i, 1) '直接调用内存中的值
Next i
MsgBox Format(Timer - t, "0.00秒")
End Sub

复制代码

Sub Test2() '用时7.32秒
Dim t As Single, i As Long, s As Long
t = Timer
For i = 1 To 1000000
s = s + Cells(i, 1) '调用单元格中的值
Next i
MsgBox Format(Timer - t, "0.00秒")
End Sub

复制代码

从上面两段代码大家可以看出，第一段代码用了数组，第二段代码是从单元格中读取数据，速度差那么远，第一段代码没有感觉到等，第二段感觉在等待。所以大家说说，要不要学数组。因为数组的运行速度快。

2. 无法永久保存

数据存放在工作表中单元格里可以永久保存，但存放在数组中数据只你要关闭Excel程序，不管是你是模块级变量，还是全局性变量，都会消失，以前的任何数组都不存在了。

三. 数组的分类

1. 按维分

(1).一维数组相当于工作表里单行，不能是单列，如果要转为单列，就要借助于工作函数里转置函数Transpose

(2).二维数组相当于工作表里单元格区域，是一个矩形区域，多行多列

(3).还有三维，四维，他们说可以到60维，我都不会，也不理解，在我们Excel里VBA几乎用不到三维，所以大家了解二维和一维就可以了。

2. 按其它的分

(1).常量数组如array("a","b","c")

(2).静态数组我们定义变量时就知道数组的维数和数组的上下界

(3).动态数组我们定义变量时不知道数组的维数和数组的上下界

四. 向数组中写于数据

Sub test1() '写入一维数组
Dim i As Integer
Dim arr(1 To 100)
arr(1) = "佛山"
arr(2) = "老鼠"
arr(3) = "佛山小老鼠"
End Sub

复制代码

Sub test2() '向二维数组写入数据,二维数组和我们工作表时的单元格区域相似，这样大家可能好理解一点
'先循环行，然后再循环列
Dim x As Integer, y As Integer
Dim arr(1 To 7, 1 To 4)
For x = 1 To 7
For y = 1 To 4
arr(x, y) = Cells(x, y)
Next y
Next x
MsgBox arr(2, 2)
End Sub

复制代码

Sub tets3() '动态数组
Dim arr(), MyRow As Integer, i As Integer '定义变量，定义Arr为动态数组，因为我们不能确定数组Arr的一维上标
MyRow = Cells(Rows.Count, 1).End(xlUp).row '取得A列最后一个数据的单元格的行号
ReDim arr(1 To MyRow, 1 To 4) '重新定义数组Arr ,大家记得，前面我们定义它Dim Arr(),现在还要给它定义一次，因为现在知道它的上标了
'所以用了 ReDim arr(1 To MyRow, 1 To 4)
For x = 1 To MyRow '遍历单元格区域，然后通过循环一一把单元格里的数据写于数组
arr(x, 1) = Cells(x, 1) '第X行第1列
arr(x, 2) = Cells(x, 2) '第X行第2列
arr(x, 3) = Cells(x, 3) '第X行第3列
arr(x, 4) = Cells(x, 4) '第X行第4列
Next x
End Sub

复制代码

Sub test4() '由常量数组导入
Dim arr
arr = Array(1, "A", 3, "佛山小老鼠")
End Sub
Sub test5() '由单元格区域导入
Dim arr '
arr = Range("a1:d7") '大家注意，这种赋值，我们就不能指定数组的上下标,如果指定就会报错
所以直接用了Dim arr
End Sub

复制代码

五. 动态数组的扩充

1. 用ReDim Preserve arr1(一维变量)，这个是扩充一维的

2. 用ReDim Preserve arr1(一维，二维变量)，这个只能扩充二维的

备注　大家务必要记得动态数组的扩充是扩展末维的，如二维的你就不能扩充一维，你只能扩充二维的变量

实例把B列有小老鼠的记录筛选出来放在F1

Sub test1()
Dim arr, arr1() '定义arr为数组，arr1为动态数组
Maxrow = Cells(Rows.Count, 2).End(xlUp).Row '最大B列最后一个有数据的行号
arr = Range("A1:D" & Maxrow) '把单元格区域一次写于数组
For i = 1 To Maxrow '遍历数组Arr中的行数据, 相当于遍历B中的数据
If arr(i, 2) = "小老鼠" Then '如果数据是“小老鼠“那么
k = k + 1 '累加K值
ReDim Preserve arr1(1 To 4, 1 To k) '重新定义数组Arr1,且要保留原有的数据，二维的下标你从1开始，那么刚好和数组 arr一致,这个地方一定要注意
'为什么二维不直接写个k,而写成1 to k,还有一个原因，Resize(k, 4)吻合。直接用K就见Test2的的写法
arr1(1, k) = arr(i, 1) '把数组Arr中符合条件重新放到新数组arr1中
arr1(2, k) = arr(i, 2) ' 大家可以这样理解它，数组arr的列就是数组arr1中的行
arr1(3, k) = arr(i, 3) '数组arr的行就是数组arr1中的列，为什么要这样呢？是因为
arr1(4, k) = arr(i, 4) '给二维数组重新定义数组时扩充只能扩充二维，不能扩充一维，最后通过转置函数又转回来
End If
Next i
[F1].Resize(k, 4) = Application.WorksheetFunction.Transpose(arr1) '又通过转置函数又转回来
End Sub

复制代码

Sub 清空()
Range("F：I").Clear
End Sub

复制代码

Sub test2()
Dim arr, arr1() '定义arr为数组，arr1为动态数组
Maxrow = Cells(Rows.Count, 2).End(xlUp).Row '最大B列最后一个有数据的行号
arr = Range("A1:D" & Maxrow) '把单元格区域一次写于数组
For i = 1 To Maxrow '遍历数组Arr中的行数据, 相当于遍历B中的数据
If arr(i, 2) = "小老鼠" Then '如果数据是"小老鼠"那么
ReDim Preserve arr1(1 To 4, k) '重新定义数组Arr1,且要保留原有的数据，二维的下标从0开始
arr1(1, k) = arr(i, 1) '把数组Arr中符合条件重新放到新数组arr1中
arr1(2, k) = arr(i, 2) ' 大家可以这样理解它，数组arr的列就是数组arr1中的行
arr1(3, k) = arr(i, 3) '数组arr的行就是数组arr1中的列，为什么要这样呢？是因为
arr1(4, k) = arr(i, 4) '给二维数组重新定义数组时扩充只能扩充二维，不能扩充一维，最后通过转置函数又转回来
k = k + 1 '累加K值
End If
Next i
[F1].Resize(k, 4) = Application.WorksheetFunction.Transpose(arr1) '能通过转置函数又转回来
End Sub

复制代码

'大家要注意，如果二维的下标从1开始，那么累加计数K=K+1就要写在重新定义数组的前面，

'如果二维的下标从0开始，也就是直接写个K ，那么累加计数K=K+1就要写在重新定义数组的最后面了，不然会报错，下标越界.

3. 另一种途径来动态数据的扩充，就比上面的方法简单了许多，也就是我首先申请足够大的空间

Dim arr1(1 To 100000, 1 To 3)

实例把B列有小老鼠的记录筛选出来放在F1

Sub test3()
Dim arr1, arr2(1 To 300000, 1 To 4) '定义一个足够大的数组空间
Maxrow = Cells(Rows.Count, 2).End(xlUp).Row '最大B列最后一个有数据的行号
arr1 = Range("A1:D" & Maxrow) '把区域赋值给数据arr1
For i = 1 To Maxrow '遍历所有数组一维
If arr1(i, 2) = "小老鼠" Then '如果数组成员有等于“老鼠”的。那么
k = k + 1 '累加k记数
arr2(k, 1) = arr1(i, 1) '满足条件，就把arr1成员写到新数组arr2里
arr2(k, 2) = arr1(i, 2)
arr2(k, 3) = arr1(i, 3)
arr2(k, 4) = arr1(i, 4)
End If
Next i
[F1].Resize(Maxrow, 4) = arr2 '把新数组一次性写于单元格
End Sub

复制代码

六. 数组的上下标

1. Lbound(数组) 可以获取数组的最小下标

2. Ubound(数组) 可以获取数组的最大上标

3. Ubound(数组,1) 可以获得数组(第1维)最大上标

4. Ubound(数组,2) 可以获得数组的(第2维)的最大上标

七. 清空数组 Erase

1. 表达式 Erase 数组名

2. 实例把A列的数据以空格为断点，依次放到E,F,G列

Sub test1()
Dim i As Long, MaxRow As Long, arr1, arr2() '定义相关的变量
MaxRow = Cells(Rows.Count, 1).End(xlUp).Row + 1 '取得A列最后一个有数据的单元格的下一个单元格
' 为什么还要加上1呢？，因为只有找到下一个空格，才会把空格上面的数据读出来
arr1 = Range("A1:A" & MaxRow) '把单元格区域写于数组
For i = 1 To MaxRow '遍历数组一维
If arr1(i, 1) = "" Then '如果数组成员为空，那么
k = k + 1 '累加k,目的是它们分别显在在E，F,G列
Cells(1, 4 + k).Resize(UBound(arr2), 1) = Application.WorksheetFunction.Transpose(arr2)
'把数组arr2一次性写于单元格区域
Erase arr2 '然后清空数组arr2空间,目的是为了存放另一空格下面的数据
x = 0 '重新初始化x，因为下一个空格下面的数据不一样，所以要归0，不然的话前面就会有空单元格出现
Else
x = x + 1 '累加x
ReDim Preserve arr2(1 To x) '重新定义动态数组Arr2
arr2(x) = arr1(i, 1) '把数组arr1满足条件的成员赋值给数组arr2
End If
Next i
End Sub
Sub test2()
Range("E:G").Clear
End Sub

复制代码

佛山小老鼠 · 发表于 2012-11-3 01:53

本帖最后由佛山小老鼠于 2012-11-8 10:54 编辑

第十四讲 VBA数组实例应用（二）

一. 函数在VBA数组中的应用

1. Split 按某一个字符把字符串截取成VBA数组,该数组是一维横向数组，编号从0开始

(1).表达式 Split(数组名，"字符")

(2).实例

Sub test() 'Split函数在数组中的应用
Dim Mystring As String '定义变量为文本型
Mystring = "W-ha-t" '把"W-ha-t"赋给Mystring
arr = Split(Mystring, "-") '按“-”用Split函数分开生成一个新的数组，赋值给数据arr
MsgBox arr(2) '显示结果为t,因为Split函数生成的一维数组，所以它的下标是0
End Sub

复制代码

2. Join 它是Split姐妹函数，把一个数组用某一个字符连接起来

(1).表达式 Join(数组名，"字符")

3. filter 按条件筛选符合条件的值组成一个新的数组

(1).表达式 filter(数组，筛选条件模糊的不能精确匹配，用True包括条件所在的/用False不包括条件所在的

4. index：引用数据，在VBA中我们当然可以用循环语句来取出工作表中单行单列数据，如果用index函数会更快一点，大家也可以用实例来证明

(1).表达式 Application.WorksheetFunction.Index(arr1, 0, 5)省略第二参数或者0，表示引用第三参数的列

(2).表达式 Application.WorksheetFunction.Index(arr1, 5, 0) 省略第三参数或者0，表示引用第二参数的行数据

5. 实例把A列到D列的数据合并为一列

Sub test()
Dim arr1, arr2(1 To 4), Maxrow As Long, x As Long, y As Long, t As Single '定义相关的变量
t = Timer '起始时间
Maxrow = Cells(Rows.Count, 1).End(xlUp).Row 'A最后一个有数据的单元格
arr1 = Range("A1:E" & Maxrow) '把单元格区域赋值给数组
For x = 1 To Maxrow '遍历数组arr1的一维
For y = 1 To 4 '遍历数组arr1的二维
arr2(y) = arr1(x, y) '把数组arr1的行数据赋值给数组arr2
Next y
arr1(x, 5) = Join(arr2, "-") '因为数组arr(x,5)是空的，所以又把用Join处理过的arr2数组里的数据又写进arr1(x,5)里
Erase arr2 '清除数据arr2,目的是为了装后面的数据
Next x '
[E1].Resize(Maxrow, 1) = Application.WorksheetFunction.Index(arr1, 0, 5) '利用Index函数又把数据读出来放在单元格E列
'这里有个要注意，那天我问了“守柔”版主，他也是在实践中发现了这个问题，引用的工作表里的数据用Index处理在VBA里不能超过
' 65536行，这个我现在也是卡着的，如果有知道的，可以指导一下，谢谢。
Columns(5).AutoFit 'E列自动适合列宽
MsgBox "用时" & Format(Timer - t, "0.00秒") '显示程序运行用时
End Sub

复制代码

6. 把A列的内容逗号进行分列

Sub test1() '可能有的学生会说，老鼠老师真傻，这个不是可能用分列实现吗，呵呵，我这里主要是为了讲Split
Dim Myrow As Long, i As Long, arr1, arr2, t As Single '定义相关的变量
t = Timer '开始记时
maxrow = Cells(Rows.Count, 1).End(xlUp).Row '取得A列最后一个有数据的单元格的行号
arr1 = Range("A1:A" & maxrow) '把区域赋给数组arr1
For i = 1 To maxrow '遍历数组arr1的一维
arr2 = Split(arr1(i, 1), "，") '按逗号分开，全部赋值给数组arr2
Cells(i, 2).Resize(1, UBound(arr2) + 1) = (arr2) '把数组arr2一次性赋值给相应的单元格
Erase arr2 '清除数组 arr2
Next i
Columns("B:H").AutoFit ' 自动适合列宽
MsgBox "用时" & Format(Timer - t, "0.00秒") '显示程序运行的时
End Sub

复制代码

Sub test2() '
Range("B:I").ClearContents '
Columns("B:I").ColumnWidth = 8.38 '
End Sub

复制代码

Sub test3() '优化代码
Dim Myrow As Long, i As Long, arr1, arr2, arr3(1 To 20000, 1 To 8), t As Single, k As Long '定义相关的变量
t = Timer ''开始记时
maxrow = Cells(Rows.Count, 1).End(xlUp).Row '取得A列最后一个有数据的单元格的行号
arr1 = Range("A1:A" & maxrow) '把区域赋给数组arr1
For i = 1 To maxrow '遍历数组arr1的一维
arr2 = Split(arr1(i, 1), "，") ''按逗号分开，全部赋值给数组arr2
For k = 0 To UBound(arr2) '遍历数组arr2的成员
arr3(i, k + 1) = arr2(k) '把数组arr2装进一个新的数组Arr3,这里要注意为什么要arr3(i, k + 1)
'因为你的k初始值是0，而你定义arr3(1 To 20000, 1 To 8)的最小下标是从1开始的，所以要加1
Next k '
Erase arr2 '清除数组arr2
Next i
Range("B1").Resize(maxrow, 8) = arr3 '把数组arr3一次性与于单元格区域
Columns("B:H").AutoFit ' 自动适合列宽
MsgBox "用时" & Format(Timer - t, "0.00秒") '显示程序运行的时
End Sub

复制代码

7. vlookup

(1).实例根据A列的姓名依次显示出它们的底薪

Sub test()
Dim Maxrow As Long, arr, arr1, arr2, arr3 '定义相关的变量
Maxrow = Cells(Rows.Count, 1).End(xlUp).Row '取得A列最后一个有数据的单元格行号
arr3 = Array("小老鼠", "代晓蓉", "张三", "李诗诗", "李飞", "马丽") '把要查找的数据赋值给数组arr3
arr = Range("A1:C" & Maxrow) '把单元格区域赋值给数组arr
arr1 = Application.WorksheetFunction.VLookup(arr3, arr, 3, 0) ' 利用Vlookup函数查找后得到一个新的数组arr1
'大家要注意，在VBA里，一般情况在工作表它的参数可以用数组，那么在VBA也可以用数组，所以Vlookup第一个参数我放了数组arr3进去了
For i = 1 To UBound(arr1) '和用循环语句把查找的结果用显示函数Msgbox显示出来
MsgBox arr3(i - 1) & "的底薪是" & arr1(i) '
Next i
End Sub

复制代码

8. 同样的方法我们可以用这几个函数来实现其它的，这里我就不多说了，同学们可以自己去尝试一下。sumif，small，large，match

二. 实例查找不及格记录

Sub test()
Dim Maxrow As Long, arr1, arr2(), i As Long, x As Long '定义相关的变量
Maxrow = Cells(Rows.Count, 1).End(xlUp).Row '取得A列最后一个数据的单元格行号
arr1 = Range("A1:D" & Maxrow) '把区域数据装入数组arr1中
For i = 1 To UBound(arr1, 1) '遍历数组arr1中的一维，相当于工作表中的行数
If arr1(i, 4) < 60 Then '如果arr1的值小于60，那么
x = x + 1 '累加x ,起到记数器的作用
ReDim Preserve arr2(1 To 4, 1 To x) '重新定义动态数组arr2,为什么这样定义呢，因为二维动态数组只能更改二维，不能更改一维
'所以把行和列选互换一下，这样就可以把数组arr1中符合条件的装过数组arr2中，处理完后再通过转置函数又要把行和列换回来
arr2(1, x) = arr1(i, 1) '
arr2(2, x) = arr1(i, 2) '
arr2(3, x) = arr1(i, 3) '
arr2(4, x) = arr1(i, 4) '
End If '
Next i
[F1:I1] = Array("学号", "姓名", "性别", "成绩") '把标题写在单元格区域F1:I1
[F2].Resize(UBound(arr2, 2), 4) = Application.WorksheetFunction.Transpose(arr2) '把数组arr2成员一次性写于单元格区域
'不过这里一定要注意，满足要求的，也就是说不及格的人数，是用UBound(arr2, 2)，不是Bound(arr2, 1)
'如果是用1，arr2数组的一维的上界是4，重新定义数组已经申明了，所以是用2，数组arr2二维的上界才是不及格的人数
End Sub

复制代码

佛山小老鼠 · 发表于 2012-11-3 01:55

本帖最后由佛山小老鼠于 2012-11-3 01:57 编辑

第十五讲字典基础知识（一）

一. 申明（大家不要以为佛山小老鼠是用字典高手，我也还是菜鸟，呵可，记住，不要拿字典来考我，我是把学字典的一点心得分享，希望能帮到比我还菜的VBA 爱好者。）

二. 开头白：字典，早一年，我刚按触VBA的时候，看到别人写的一些代码怎么也看不懂，后来听别人说，一是Vba里的数组，还有就是字典，这两个知识点可以优化代码和提高代码的运行速度，于是，我也蠢蠢欲动，可以怎么也不明白。于是放弃了学习VBA，因为自己会写代码，也是一些简单的录制宏，修改宏，最多也只能用上循环语句。很羡慕VBA高手写的那些长长的代码，那天我的水平有这么高就好了，然后我到ExcelHome论坛上找了这方面的资料，如“山菊花老师的墙上那一串串红辣椒——数组入门讲座”，“蓝桥玄霜老师：常见字典用法集锦及代码详解”，以及“蓝色幻想”老师的一些视频和贴子，真的很感谢这些老师，总算把我这个菜鸟带入了门

1. 字典的引用方式

(1). 前期绑定：方法——>>Alt+F11——>>工具菜单——>>引用——>>浏览——>>选择scrrun.dll。如图 26

a. 优点：对于刚学习字典的朋友好，可以弹出成员列表出来。

b. 缺点：把文件发给别人，别人如果不引用下面这个动态Dll文件就不能用这段代码

图 26

(2). 后期绑定要用代码实现

方法

Set dic= CreateObject("scripting.dictionary")

a. 优点：可以发给别人使用，不要担心不能用了

b. 缺点：不利用编程人员编辑代码

(3). 备注：有时可能还是用不了，Windows的开始——>>运行——>>输入Regsvr32 Scrrun.D11——>>确定，如果还是失败，那么说明你的电脑没有这个动态库Scrrun.D11，这时你到网上去下载这个，或者你别人的电脑上复制过来这个Scrrun.D11，然后放在C:\WINDOWS\system32文件夹下，再进行上面的注册，Windows的开始——>>运行——>>输入Regsvr32 Scrrun.D11——>>确定

三. 字典的优势

1. 字典可以创建二列的二维数组，更加灵活

(1). 如果工作表有多列，大家可以用“&”把它们连接起来，再装进字典里

2. 字典的一些属性可读可写

(1). Key和Item可读可写

(2). Keys和Items方法可以转为一维数组，然后再通过转置函数Transpose转为纵向写于单元格

3. 字典里Key关键字具有唯一性

(1). 可以用来去重复值

(2). 可以用来分类汇总

4. 具体我们到后面的实例去了解

四. 向字典里装入数据

1. 前期绑定的装入见实例

Sub test() '这是前期绑定的，方法工具菜单-->>引用-->>浏览-->>选择scrrun.dll-->>打开
Dim dic As New Dictionary, arr, arr1, arr2, Maxrow As Long, i As Long, x As Long '定义相关的变量
Maxrow = Cells(Rows.Count, 1).End(xlUp).Row '取得A列最后有数据的单元格的行号
arr = Range("A1:B" & Maxrow) '把区域转为二维数组
For i = 1 To UBound(arr, 1) '遍历数组arr里一维
dic.Add arr(i, 1), arr(i, 2) '把数组arr里的成员装入字典
Next i
arr1 = dic.Keys '因为Keys和Items是方法，所以不能写成Keys(1),因此这里要倒一下，绕过圈，dic.Keys先装入数组，然后数组就可以引用了
arr2 = dic.Items '
For x = 1 To dic.Count - 1 '本来是从0开始的，因为dic.Keys和dic.Items得到的数组都是下标从0开始的一维数组，且第一行是表头
MsgBox arr1(x) & "的底薪是" & arr2(x) '通过循环依次显示结果
Next x
End Sub

复制代码

2. 后期绑定的装入

Sub test() '这是后期绑定的
Dim dic As Object, arr, arr1, arr2, Maxrow As Long, i As Long, x As Long '定义相关的变量
Set dic = CreateObject("scripting.dictionary")
Maxrow = Cells(Rows.Count, 1).End(xlUp).Row '取得A列最后有数据的单元格的行号
arr = Range("A1:B" & Maxrow) '把区域转为二维数组
For i = 1 To UBound(arr, 1) '遍历数组arr里一维
dic.Add arr(i, 1), arr(i, 2) '把数组arr里的成员装入字典
Next i
arr1 = dic.Keys '因为Keys和Items是方法，所以不能写成Keys(1),因此这里要倒一下，绕过圈，dic.Keys先装入数组，然后数组就可以引用了
arr2 = dic.Items '
For x = 1 To dic.Count - 1 '本来是从0开始的，因为dic.Keys和dic.Items得到的数组都是下标从0开始的一维数组，且第一行是表头
MsgBox arr1(x) & "的底薪是" & arr2(x) '通过循环依次显示结果
Next x
End Sub

复制代码

五. 从字典中读中数据

1. 实例去重复值

Sub test() '没有用防错语句
Dim dic As Object '定义变量
Set dic = CreateObject("scripting.dictionary") '引用字典
Maxrow = Cells(Rows.Count, 1).End(xlUp).Row '取得A列最后一个有数据单元格的行号
arr = Range("A1:A" & Maxrow) '把单元格区域数据装入二组数组arr里
For i = 1 To UBound(arr) '遍因数据arr的一维，相当于遍历单元格区域的行
dic(arr(i, 1)) = "" '把数组成员一一加入字典里，Item没有我们就把它等于空，也就是只装了字典的Key
'这种表达方，如果有重复就会覆盖，不会报错，如果用Add的方法就要在前面加一句On error resume next
Next i
[B1].Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(dic.Keys) '
'因为dic.keys和dic.items得到都是一维数组，且下标从0开始的，所以要用转置函数
End Sub

复制代码

Sub test1() '用防错语句
Dim dic As Object '定义变量
On Error Resume Next '屏蔽添加重复的报错
Set dic = CreateObject("scripting.dictionary") '引用字典
Maxrow = Cells(Rows.Count, 1).End(xlUp).Row '取得A列最后一个有数据单元格的行号
arr = Range("A1:A" & Maxrow) '把单元格区域数据装入二组数组arr里
For i = 1 To UBound(arr) '遍因数据arr的一维，相当于遍历单元格区域的行
dic.Add arr(i, 1), "" '把数组成员一一加入字典里，Item没有我们就把它等于空，也就是只装了字典的Key
'这种表达方，如果有重复就会会报错，就要在前面加一句On error resume next
Next i
[B1].Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(dic.Keys) '
'因为dic.keys和dic.items得到都是一维数组，且下标从0开始的，所以要用转置函数
End Sub

复制代码

备注：直接读取用了dic.Keys和dic.Items，如果要循环，那么就要倒传一下，绕过圈，先把dic.Keys和dic.Items赋给数组，也就是装进数组，然后循环数组，因为不能这样引用dic.Keys（0）

六. 修改字典里的数据

可以直接用dic("关键字")=“某一个值”，这“某一个值”就是条目对了

Sub test() '修改字典里的数据
Dim dic As Object, arr, arr1, arr2, Maxrow As Long, i As Long, x As Long '定义相关的变量
Set dic = CreateObject("scripting.dictionary")
Maxrow = Cells(Rows.Count, 1).End(xlUp).Row '取得A列最后有数据的单元格的行号
arr = Range("A1:B" & Maxrow) '把区域转为二维数组
For i = 1 To UBound(arr, 1) '遍历数组arr里一维
dic.Add arr(i, 1), arr(i, 2) '把数组arr里的成员装入字典
Next i
'dic("小老鼠") = 999 '然后我们又把这一句前面加一个逗号去掉让运行看看，发现前面一次1000，去掉逗号之后是999，可以直接用dic("关键字")=“某一个值”，这“某一个值”就是条目对了
arr1 = dic.Keys '因为Keys和Items是方法，所以不能写成Keys(1),因此这里要倒一下，绕过圈，dic.Keys先装入数组，然后数组就可以引用了
arr2 = dic.Items '
For x = 1 To dic.Count - 1 '本来是从0开始的，因为dic.Keys和dic.Items得到的数组都是下标从0开始的一维数组，且第一行是表头
MsgBox arr1(x) & "的底薪是" & arr2(x) '通过循环依次显示结果
Next x
End Sub

复制代码

七. 删除字典里的数据

1. 删除某一个关键字表达式 dic.Remove "关键字"

2. 删除全部关键字表达式 dic.Removeall

Sub test1() '删除字典里的数据
Dim dic As Object, arr, arr1, arr2, Maxrow As Long, i As Long, x As Long '定义相关的变量
Set dic = CreateObject("scripting.dictionary")
Maxrow = Cells(Rows.Count, 1).End(xlUp).Row '取得A列最后有数据的单元格的行号
arr = Range("A1:B" & Maxrow) '把区域转为二维数组
For i = 1 To UBound(arr, 1) '遍历数组arr里一维
dic.Add arr(i, 1), arr(i, 2) '把数组arr里的成员装入字典
Next i
' dic.Remove "小老鼠" '然后我们又把这一句前面加一个逗号去掉让运行看看，发现前面“小老鼠”这个关键字和对应的条目对没有了
' MsgBox dic.exists("小老鼠")'显示结果为False
' dic.RemoveAll'当你把这个前面单引用号去，运行什么也没有了，包括输出函数Msgbox,因为Dic.count=0了
arr1 = dic.Keys '因为Keys和Items是方法，所以不能写成Keys(1),因此这里要倒一下，绕过圈，dic.Keys先装入数组，然后数组就可以引用了
arr2 = dic.Items '
For x = 1 To dic.Count - 1 '本来是从0开始的，因为dic.Keys和dic.Items得到的数组都是下标从0开始的一维数组，且第一行是表头
MsgBox arr1(x) & "的底薪是" & arr2(x) '通过循环依次显示结果
Next x
End Sub

复制代码

八. 判断某一“关键字”是否存在，用dic.exists("关键字")

佛山小老鼠 · 发表于 2012-11-3 01:59

第十六讲 字典实例应用（二）

一. 利用字典里的关键词的唯一性，在添加关键词把条目对的值也同时添加为1，2，4，4，5……，这样就把数组里的重复值名字去掉了，且数组里的索引号和字典里的条目对是一致的，且把数值累加，起到了分类汇总的作用。

二. 实例一：多列汇总，按A列的产品名称，把B列的数和C列的金额汇总

Sub test()
'定义相关的变量
Dim arr(1 To 10000, 1 To 3), arr1, dic As Object, i As Long, k As Long, hang As Long, Maxrow As Long, t As Single
t = Timer '开始记时
Maxrow = Cells(Rows.Count, 1).End(xlUp).Row '找到A列最后一个有数据单元格的行号
Set dic = CreateObject("scripting.dictionary") '创建字典
arr1 = Range("A2:C" & Maxrow) '把单元格区域装入数组
For i = 1 To UBound(arr1, 1) '遍历数组arr1的一维
If dic.exists(arr1(i, 1)) Then '如果字典里存在arr1这个关键词，那么
hang = dic(arr1(i, 1)) '找到这个关键词在字典里的位置，对应的Item,而字典里这种Item位置刚好和数组arr的一维对应
arr(hang, 2) = arr(hang, 2) + arr1(i, 2) '累加数组arr前面所对应的数量
arr(hang, 3) = arr(hang, 3) + arr1(i, 3) '累加数组arr前面所对应的金额
Else
k = k + 1 '累加k
dic(arr1(i, 1)) = k '把关键字arr1（i,1)添加到字典里，且条目对为k
arr(k, 1) = arr1(i, 1) '把数组arr1里的第i行第1列的数据装进一个新的arr数组里的第k行第1列
arr(k, 2) = arr1(i, 2) ''把数组arr1里的第i行第2列的数据装进一个新的arr数组里的第k行第2列
arr(k, 3) = arr1(i, 3) ''把数组arr1里的第i行第3列的数据装进一个新的arr数组里的第k行第3列
End If
Next i
[E1:G1] = Array("产品名称", "数量", "金额") '
Range("E2").Resize(k, 3) = arr
MsgBox "用时" & Format(Timer - t, "0.00秒") '
End Sub

复制代码

三. 实例2 按照A列的产品称和B列的型号对C列和D列的数据进行汇总

Sub test()
'定义相关的变量
Dim arr(1 To 10000, 1 To 4), arr1, dic As Object, i As Long, k As Long, hang As Long, Maxrow As Long, t As Single
t = Timer '开始记时
Maxrow = Cells(Rows.Count, 1).End(xlUp).Row '找到A列最后一个有数据单元格的行号
Set dic = CreateObject("scripting.dictionary") '创建字典
arr1 = Range("A2:D" & Maxrow) '把单元格区域装入数组
For i = 1 To UBound(arr1, 1) '遍历数组arr1的一维
Mystring = arr1(i, 1) & arr1(i, 2) '把两个合起来为一个，因为字典的关键词只能装进一列
If dic.Exists(Mystring) Then '如果字典里存在arr1这个关键词，那么
hang = dic(Mystring) '找到这个关键词在字典里的位置，对应的Item,而字典里这种Item位置刚好和数组arr的一维对应
'把字典里的相应的关键键对应的条目对值赋给hang
arr(hang, 3) = arr(hang, 3) + arr1(i, 3) '累加数组arr前面所对应的数量
arr(hang, 4) = arr(hang, 4) + arr1(i, 4) '累加数组arr前面所对应的金额
Else
k = k + 1 '累加k
dic(Mystring) = k '把关键字Mystring添加到字典里，且条目对为k
arr(k, 1) = arr1(i, 1) '把数组arr1里的第i行第1列的数据装进一个新的arr数组里的第k行第1列
arr(k, 2) = arr1(i, 2) ''把数组arr1里的第i行第2列的数据装进一个新的arr数组里的第k行第2列
arr(k, 3) = arr1(i, 3) ''把数组arr1里的第i行第3列的数据装进一个新的arr数组里的第k行第3列
arr(k, 4) = arr1(i, 4) ''把数组arr1里的第i行第4列的数据装进一个新的arr数组里的第k行第4列
End If
Next i
[E1:H1] = Array("产品名称", "型号", "数量", "金额") '
Range("E2").Resize(k, 4) = arr
MsgBox "用时" & Format(Timer - t, "0.00秒") '
End Sub

复制代码

佛山小老鼠 · 发表于 2012-11-3 02:01

第十七讲 自定义右键菜单

一. 实例代码

Sub 添加右键菜单() '过程的名称,Sub是开始的意思
Dim cd As CommandBarButton '定义变量
'Dim定义变量的意思,As象什么,CommandBarButton是按钮的意思
On Error Resume Next '为了防止没有添加就删除会报错
Application.CommandBars("cell").Controls("签名").Delete '删除右键"签名"按钮
Application.CommandBars("cell").Controls("日期").Delete '删除右键"日期"按钮
Set cd = Application.CommandBars("cell").Controls.Add(Type:=msoControlButton, before:=1)
'set是给的意思,赋值的意思;appication是EXCEL程序的意思;CommandBars是菜单的意思;Cell是右键菜单的意思;
'Controls是指右键菜单上的按钮集合;Add是添加的意思;Type是类型的意思;msoControlButton是按钮型;Before:在什么的前面的意思
With cd 'cd相当于我们说话的主语了,后面的语句就可以省略这个主语
.Caption = "签名" 'Caption是指这个按钮在右键菜单上的名字'
.FaceId = 483 'FaceId是指图标
.OnAction = "签字" 'OnAction是指这个按钮关联的过程和动作'
End With
Set ce = Application.CommandBars("cell").Controls.Add(Type:=msoControlButton, before:=2)
'set是给的意思,赋值的意思;appication是EXCEL程序的意思;CommandBars是菜单的意思;Cell是右键菜单的意思;
'Controls是指右键菜单上的按钮集合;Add是添加的意思;Type是类型的意思;msoControlButton是按钮型;Before:在什么的前面的意思
With ce 'cd相当于我们说话的主语了,后面的语句就可以省略这个主语
.Caption = "日期" 'Caption是指这个按钮在右键菜单上的名字'
.FaceId = 484 'FaceId是指图标
.OnAction = "日期" 'OnAction是指这个按钮关联的过程和动作'
End With
End Sub '结束过程 end是结束意思

复制代码

Sub 签字()
Selection = "老鼠"
End Sub

复制代码

Sub 恢复右键菜单()
Application.CommandBars("cell").Reset
End Sub

复制代码

Sub 日期()
Selection = Date
Columns.AutoFit
End Sub

复制代码

上面是普通模块里的代码，下面是工作簿模块里的代码

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.CommandBars("cell").Controls("签名").Delete
Application.CommandBars("cell").Controls("日期").Delete
End Sub
Private Sub Workbook_Open()
添加右键菜单
End Sub

复制代码

		自动登录	找回密码
密码			免费注册

佛山小老鼠说Excel VBA

评分

评分

评分

评分

评分

评分

评分