佛山小老鼠带您走进VBA数组(菜鸟请进)

佛山小老鼠 · 发表于 2013-11-13 00:13

本帖最后由佛山小老鼠于 2015-10-5 10:07 编辑

佛山小老鼠带您走进VBA数组(菜鸟请进)

(此帖2013年11月17日零晨2点50分结帖)

一、前言

1.大家晚上好,快零晨了,写本帖的目的是为帮助那些VBA长久不能入门的朋友而苦脑的,如果你是久久不能入门的朋友,往往是在VBA数组这里卡住了,好好的一起来交流学习VBA数组,当然我先申明,我也只会二维数组,三维数组我也不会,高手就飘过,当然欢迎高手露二手.

2.先说说我学习VBA过程

（1）初识VBA阶段

目前我自己对自己的VBA水平打了一个等级，算一个中级用户吧，把自己走过来这一段聊聊，同学们记住，不能说我“八”和“二”我把自己从2009年到现在学习VBA的过程说一下。我是EH第一个VBA班的学生，当时讲师是叶枫老师，也就是“别怕，excel VBA 其实很简单”的作者，打心里话，从零基础到现在VBA中级用户，而我也是一个非计算机专业，且我学的专业是体育，包括现在我都不专业，经常说的一些术语都不对，如果没有EH这样平台和EH会员及管理的陪伴，我想不可能达到VBA中级水平，中间也放弃过好多次,不学VBA了,说真的，我这里建议大家多分享，俗话说的好：“我为人人，人人为我”，是因为一些老会员把自己的经验分享给我们新手，所以我们新手才有学习资料，才能不断的提高。记得哦，有时间，在EH这个平台多写写帖，这也是你的Excel人生的一个里程碑,同时在写的过程中,其实你对自己这些知识点一个总结,无形中提升自己,当我们80岁时,看回过头来看看,也是一种荣誉啊.如果个个不分享就没有今天的EH.强烈建议大家有空分享一些文章.当时EH培训开班我记得是2010年3月份,那时真的很激动,特别是报名合格那一刻.兴奋啊!,拉拉拉拉……，我可以学VBA了！，课件是以视频的形式发下来的，视频只能播放5次，自己很珍惜，看了一次又看了一次，每一次都是很认真的。总共是四节课，后来就毕业了。虽然自己毕业之后没有入门，但是与自己之前没有参入培训是提高了好多，也明白了录制宏，也明白录制宏里相对和绝对，也理解代码写在那里，更高兴就是“高亮显示行”，虽然当时不懂，但也明白是工作表事件触发了代码运行。

（2）纠结阶段

我当时学习方法是这样的,闲时就到论坛找找一些入门帖下载,然后有空时自学,当然好多看不懂,虽然看不懂,当时还是会去看的,因为看了至少让我不明白又少了一些,再有就是到QQ群里看别人的提问与回答.有时自己也会回复一下别的的VBA提问,如果答对了,别人送给你一个"竖起的大拇指",心里是很爽的,不错不错,更加增强自己学习VBA的信心和兴趣,简单一些对象,属性,方法还是能理解了,可是当看到别写的长长的代码中有arr1,arr2,Ubound(arr1,1),Ubound(arr1,2),redim arr1(1 to 10000,1 to x), ReDim Preserve arr1(1 To 10000, 1 To y),arr1 = Range("A1").CurrentRegion,arr1 = Range("A1").CurrentRegion.Offset(2),我的妈,这些是些什么,我录制宏时怎么都没有见过.后来别人说是数组里知识.我就到图书馆去找这方面的VBA的书,可是市面上本来VBA方面的书少,且有的书提过VBA数组,也是篇幅有限,写的不详细,对手我这样菜鸟,也只能望“书”兴叹了，后来在论坛上找到了这几个帖，建议新手下载学习一下

1.山菊花老师的《墙上那一串串红辣椒——数组入门讲座》http://club.excelhome.net/thread-196095-1-1.html

2.叶枫老师的《菜鸟谈VBA最最基础入门原创》http://club.excelhome.net/thread-470603-1-1.html

3.怀英慕者老师的VBA数组通俗教程（初稿）http://club.excelhome.net/thread-770881-1-1.html

4.yagi2008老师的《 VBA入门指南——献给在这里得到帮助但看不懂代码的朋友》http://club.excelhome.net/thread-390711-1-1.html

这些贴对我帮助很大，理解VBA基础和VBA数组，可是当时我对VBA数组还是不懂，在2011年6月放弃了学VBA，因为学不会VBA数组，差不多半年也没有学习VBA了，认为自己学会VBA数组了，到了2012年春节，由于时间比较多,不过对excel一直都有激情,不学VBA并不影响我对excel学习,我就开发"完美工具箱了"

"完美工具箱"下载地址http://club.excelhome.net/thread-851978-1-1.html

也许你不知道当时我在完美工具箱写的源代码,你看了一定会笑,为什么呢?因为我大部程序都是读取对象完成的,所以早期许多版本一些程序运行会excel程序假死,有目标才有动力,我也明白是因为我不会VBA数组的原因,许多代码可以优化.于是我下定决心,再学VBA数组,这次学VBA数组终于开窍了,大家打起精神,要打起十二分的精神,我把学会VBA数组秘密告诉大家"在本地窗口查看数组的空间结构",方法:Alt+F11==>视图菜单==>本地窗口.

在"本地窗口查看数组的空间结构"和其它变量的变化情况就像我们在学工作表数组函数通过F9查看各函数的结果一样.大家都知道在函数数组,一定要学会按F9查看结果,说的土一点,如果你不会用F9查看数组函数的运算结果,我想你很理解数组函数,同学们,我说的对不对?

(3)进阶阶段

第一:用VBA数组来解决自己用的工作簿和工作表上的问题,这样提升会更一点,这样可以增加你这VBA数组的兴趣

第二:多看看别人写的代码,别人为什么这样写,这样写的好处

第三:多动手写

第四:学会自己给代码找错误,多次调试代码

遇到错误许多朋友,马上想到请教别人,或者发贴到论坛上求助,大仙,大神救救我,急用,这一段代码报错了,不知为什么?帮帮忙,其实我也是这样认为的,代码有问题,按F5运行,F9设置断点,F8逐步运行,再加上打开本地窗口看变量和数组的空间结构,相信错误一定会查个水落石出.如果是别人帮了你弄好,我想下次你遇到,有可能你还是会犯这样的错误,如果你是自己找到错语所在,我想你一定会永远记住它.举个例子,同学们不准笑,要严肃一点

第一个有错误的代码
Option Explicit
Sub test()
Call 自已
End Sub
Sub 自己()
msbgox "亲:您好!", 64, "问候"
End Sub

我运行第一个过程,想调用第二个过程,为什么不对?我想啊想,我想啊想,怎么想不明白?想明的同学们告诉我错在那里,我定给你加财富10￥

第二个错误
是一个自定义函数，大家找出错误我也加财富10￥
Option Explicit
Function XFD1(Rg As Range) '这个函数作用就是返回参数单元格的行号
XFD1 = Rg.Row
End Function

第三个错误
Option Explicit
Sub 取左边的第一个数据再求和()
Dim a%, b%, c%, s%
a = 11
b = 21
c = 31
s = Left(a, 1) + Left(b, 1) + Left(c, 1)
MsgBox "求和结果是: " & s
End Sub
为什么结果是123，应该是6

第四个错误
Sub 筛选()
Range("A1:C100").AutoFilter field:=3, Criterial:="佛山小老鼠"
End Sub
上面代码错误在那里，如果错了，怎样修改？

同学位加油啊，找到四个错误各加财富10￥，说清楚只加第一个人回答对的。
个人认为，找代码找错误也是非常重要，非常重要。所以建议大家代码有错误先一定要自己深思熟虑之后，确是没有办法，再求助别人，这样更利于搞自己的水平。

欢迎加入QQ交流群2801-7317-4

佛山小老鼠 · 发表于 2013-11-13 00:14

本帖最后由佛山小老鼠于 2013-11-15 01:44 编辑

为什么要学习数组

1.为了提速,提高代码运行速度

先我看看二段代码

Option Explicit
Sub 读取对象求和1() '用读取单元格对象的方法
Dim t!, s&, x&, y&
t = Timer '
y = Cells(Rows.Count, 1).End(xlUp).Row
For x = 1 To y
s = s + Range("A" & x).Value
Next x
MsgBox "用时" & Format(Timer - t, "0.00秒")
MsgBox "求出的和是: " & s
End Sub

Sub 用数组方法求和()
Dim t!, s&, x&, arr1
t = Timer
arr1 = Range("A1").CurrentRegion
For x = 1 To UBound(arr1)
s = s + arr1(x, 1)
Next x
MsgBox "用时" & Format(Timer - t, "0.00秒")
MsgBox "求出的和是: " & s
End Sub

同学位,我们从上面两段代码运行的速度可以明显看出,速度差异如些的大!大家说说,我们有必要学习VBA数组吗?,一个用时3.69秒,一个用时是0.08秒,当然和电脑配置有关,可能有的同学测试出来的比我的速度还快,有的比我的还慢,如果你测试,也可以在下面跟帖,晒晒你的测试运行的结果.

2.简化代码

我们下面也有二段代码,都是动态的提取第一行的表头
Option Explicit
Sub 数组方法()
Dim arr1
arr1 = Sheets(1).[A1].CurrentRegion
[A1].Resize(1, UBound(arr1, 2)) = arr1
End Sub
Sub 复制粘贴的方法()
Dim LastColumn%
LastColumn = Cells(1, Columns.Count).End(xlToLeft).Column
Sheets(1).Range("A1:F" & LastColumn).Copy
[A1].PasteSpecial xlPasteAll
End Sub
Sub 删除表头()
[A1:F1] = ""
End Sub

从上面二段代码我们可以看出,用“数组的方法”代码相对来说比“复制粘贴的方法”代码简化一些，当然我也不说代码越简单就是好的代码

佛山小老鼠 · 发表于 2013-11-13 00:16

本帖最后由佛山小老鼠于 2013-11-16 03:02 编辑

数组的申明

一、数组的分类

1.按维数分：一维,二维，多维

我是这样理解的，线是由点组成的，面是由线组成的，一维数组就像一条线，如我们工作表里的行，列，一行里的单元格，一列里的单元格就是数组里的元素，我通常把它叫做数组里的成员，二维数组就像一个面，如我们的工作表就是一个平面，工作表里的单元格也是二组数组里的元素.

2.按空间结构大小是否改变分：静态数组和动态数组

Option Explicit
Sub 静态数组1()'这个是表示8行1列的一维数组
Dim arr1(1 To 8)
End Sub
Sub 静态数组2()'这个是表示8行2列的二数数组
Dim arr1(1 To 8, 1 To 2)
End Sub

Sub 静态数组3()'这个是表示9行1列的一维数组
Dim arr1(8)
End Sub

Sub 静态数组4()' 这个是表示9行3列的二维数组
Dim arr1(8, 2)
End Sub

上面是静态的数组

===========================================================

Option Explicit
Sub 动态数组1()

Dim x%
Dim arr1()'定义动态数,为什么要定义动态数组呢,是因为我们刚开始时不知数组的空间结构,所以用dim arr1()
x = 5
ReDim arr1(1 To 5)'由于我们后来可以确定它的大小 ,所以用关键词Redim重新给数组arr1分配空间,5行1列的一维数组
x = 10
ReDim arr1(1 To 10)'又重新给数组arr1分配空间,10行1列的一维数组,不过大家要注意,如果没有加Preserve ,重新分配空间之后,会删除前面的值,也就是说不会

''保留数组原有值,这一点很重要.同学们一定要记住.
End Sub
Sub 动态数组2()

Dim x%
Dim arr1()
x = 5

x = 10
ReDim arr1(1 To 10, 1 To x)
End Sub
ReDim arr1(1 To 5, 1 To x)'表示5行5列的二维数组,有的同学说,老师,可不可以把定义成这样,Dim arr1(1 to x,1 to 5),答案是否定的,不可以,也就是我们只能改变末维的大小,如三维的 Redim (1 to 1 ,1 to 1, 1 to x),也就是说我们变量只能放在三维上,不能放在一维Redim (1 to x,1 to 1, 1 to 1),

也不能放在二维上如Redim (1 to x,1 to x, 1 to 1),

正确的定义:Redim (1 to 1 ,1 to 1, 1 to x),

错误的定义:Redim (1 to x,1 to 1, 1 to 1)

错误的定义:Redim (1 to x,1 to x, 1 to 1)
Sub 动态数组3()

Dim x%
Dim arr1()
x = 1
ReDim Preserve arr1(1 To 2, 1 To x)'表示2行1列的二维数组且保留原有值
x = 2
ReDim arr1(1 To 2, 1 To x)'表示2行2列的二维数组且保留原有值
End Sub

上面是动态数组

===================================================

下面是一段对白：

小白学生说：,我的老鼠老师,你说了那么一大堆,

汉……

哇……啦……啦……啦……啦……啦……

看得我云里雾里了,我都晕倒电脑旁边

老鼠老师说：我的亲：您可千万别晕啊，您晕了没有人关电脑了，我可不会帮你关机！

小白学生说：那老鼠老师您有没有什么绝招让我们不晕啊？

老鼠老师说：有啊，其实，我早就告诉您了，那一个神器，只是你上课不认真呢？

小白学生说：我的好老师，你就别买关子了，就告诉我们吧

老鼠老师说：再学习一遍一楼的帖

小白学生说：老鼠老师，我明白了，视图菜单，本地窗口，把光标点到你要测试代码里，F8逐步运行，查看本地窗口，哈哈，点一个那个节点+号，原来数组的空间结构一目了然了。明白了明白了。真开心啊

老鼠老师说：真聪明

总结一下，不开玩笑了，言归正传

我们现在举一个实例来学习

打开excel程序--->alt+f11---->插入菜单--->插入模块---> 把下面代码复制到模块里去

Sub 动态数组理解()
Dim arr1(), x% '定义变量
x = 1 '第一次给x赋值为1
ReDim arr1(1 To 2, 1 To x) '给数组arr1分配空间,2行1列的二维数组
arr1(1, 1) = "佛山小老鼠" '把"佛山小老鼠"赋值给arr1里第1行第1列位置
arr1(2, 1) = "学生" '把"学生"赋值给arr1里第1行第2列位置
x = 2 '第二次给x赋值为1
ReDim Preserve arr1(1 To 2, 1 To x) '再给数组arr1重新分配空间,2行2列的二维数组
'且保留原有值
arr1(1, 2) = 99 '把99赋值给数组arr1里第1行第2列位置
arr1(2, 2) = 88 '把88赋值给数组arr1里第1行第2列位置
End Sub

同学们注意,把光标点到上面这段代码里 F8逐上步运行,按照老师下面的截图步骤

图一.jpg

佛山小老鼠 · 发表于 2013-11-13 00:17

本帖最后由佛山小老鼠于 2013-11-16 03:01 编辑

把工作表里的数据写进数组里

大家记得我说的这句话,所有单元格区域装入到数组里都是二维数组,且定义数组大小时,我们都是直接写成这样 dim arr1,不要给它分配空间大小,也不要在其后面加一对空的小括号

1.二个连续的单元格区域写进数组里

Option Explicit
Sub 二个单元装入到数组里()
Dim arr1
arr1 = Sheets(1).Range("A1:A2")
End Sub

2.同一行里连续5个单元格装入数组里

Sub 一行连续五个单元格装入到数组()
Dim arr1
arr1 = Sheets(2).Range("A1:E1")
End Sub

3.同一列里连续5个单元格装入数组里

Sub 一列连续五个单元格装入数组()
Dim arr1
arr1 = Sheets(3).Range("A1:A5")
End Sub

4.多行多列连续单元格区域装入数组里

Sub 五行五列单元格区域装入数组()
Dim arr1
arr1 = Sheets(4).Range("A1").CurrentRegion
End Sub

5.通过函数Array把数据装入到数里

Sub 通过Aarry函数把数据装入到数组里()
Dim arr1
arr1 = Array("佛山小老鼠", "李诗", "阿梅", "小平")
'大家记得,通过函数array装进数组arr1里,是一维的,且第一个索引号是从0开始
End Sub

总结一下:

老鼠老师问:"小白同学,这一节课你学会了没有?"

小白回答:老鼠老师,我这次没有晕,我想送给你一首歌"

老鼠老师说:什么歌?

小白回答:那我唱了,老师,“"最爱喝的水永远是黄河水,最爱说的话永远是中国话，最爱查的窗口永远是本地窗口”

老鼠老师说:谢谢小白同学的歌，老师知道您学会了这一节课，看您唱得那么开心。

佛山小老鼠 · 发表于 2013-11-13 00:19

本帖最后由佛山小老鼠于 2020-4-23 22:44 编辑

把数据从数组读出来

1.一维数组读出来放在工作表里一行里

Option Explicit
Sub 一维数组读一行里()
Dim arr1
arr1 = Array("佛山小老鼠", "张三", "李四", "小妮子", "丫头")
Range("A1").Resize(1, UBound(arr1) + 1) = arr1
End Sub
Sub 清空()
Range("A1:E1") = ""
End Sub

2.一维数组读出来放在工作表里一列里

Sub 一维数组读一列里()
Dim arr1
arr1 = Array("佛山小老鼠", "张三", "李四", "小妮子", "丫头")
Range("A1").Resize(UBound(arr1) + 1, 1) = Application.WorksheetFunction.Transpose(arr1)
’由于一维数组读到单元格只能读成横向的,所以我们要通过转置函数Transpose,转成纵向的
End Sub

3.二维数组读出到工作表里

Sub 把二维数组读到单元格中()
Dim arr1
arr1 = Range("A1").CurrentRegion
[E1].Resize(UBound(arr1, 1), UBound(arr1, 2)) = arr1
'函数Ubound是取得数组arr1最大的索引号,
'UBound(arr1, 1)数组arr1最大的行索引号
'UBound(arr1, 2))最大的列索引号
End Sub

4.由于部分函数只支持一维数组，而我们单元格区域装入数组都是二维的，怎么办？

A.工作表里一行数据转一维

Sub 工作表里一行数据转一维1() '分开写的
Dim arr1, arr2, arr3
arr1 = Range("A1:E1")
arr2 = Application.WorksheetFunction.Transpose(arr1)
arr3 = Application.WorksheetFunction.Transpose(arr2)
End Sub

Sub 工作表里一行数据转一维2() '合起写的
Dim arr1, arr2
arr1 = Range("A1:E1")
arr2 = Application.WorksheetFunction.Transpose(Application.WorksheetFunction.Transpose(arr1))
'为什么要转二次呢,因为第一次是把1行5列的二维数组转置成5行1列的二维数组
第二次是把5行1列的二维数组转成一维数组
End Sub

Sub 工作表里一行数据转一维3() '简写的
Dim arr1, arr2
arr1 = Range("A1:E1")
arr2 = Application.Transpose(Application.Transpose(arr1))
'我们可以把二个WorksheetFunction省略
End Sub

B.一工作表里一列数据转一维

Sub 工作表里一列数据转一维()
Dim arr1, arr2
arr1 = Range("A1:A5")
arr2 = Application.WorksheetFunction.Transpose(arr1)
'如果是工作表里的一列装到数组里,只需转一次
End Sub

佛山小老鼠 · 发表于 2013-11-13 00:20

本帖最后由佛山小老鼠于 2013-11-17 00:31 编辑

动态数组

1.动态数组我是这样理解的,它的空间结构大小不断变化,或者说我们开始不能确定其空间大小,因此我们用一对空括号里来声明

如下面的

A.第一种'由于刚开始不能确定数组空间大小,要根据工作表里数据区域大小来确定

Option Explicit
Sub 动态数组() '你可以在C列后面不断添加数据,
'动态数arr2的列数也不会自动不断的增加
Dim arr2(), arr1 '定义相关变量,数组arr2为动态数组
Sheets("动态数组1").Activate '把工作表""设置为活动工作表
arr1 = Range("A1").CurrentRegion '把数据装入到数组arr1
ReDim arr2(1 To 10000, 1 To UBound(arr1, 2)) '重新定义数组arr2的空间结构大小
End Sub

B.第二种从一个数组中把满足条件装入到另一个数组中,这时需要不断地扩大数组空间最后维度的大小,当然不能扩展中间维度大小,这个前面我们已经说过了,打个比方,当然一维数组不存在这种问题,而二维,二维以上就要注意了,

如下面的,你只能这样

Sub test1()
  Dim arr1(), x%
  For x = 1 To 5
ReDim arr1(1 To 3, 1 To x)
  Next x
End Sub
而不能在数组的行上改变,也就是说数组arr1的一维不能放变量x,而只能在数组arr1的二维上放变量x

下面就是错误的

Sub test1()
  Dim arr1(), x%
  For x = 1 To 5
ReDim arr1(1 To x, 1 To 3)
  Next x
End Sub

另大家也要注意一点,因为不断的修改数组的空间大小,修改一次都会清空原有值,如果你想保留必须加Preserve

如下面的代码

Sub test1()
  Dim arr1(), x%
  For x = 1 To 5
ReDim Preserve arr1(1 To 3, 1 To x)
  Next x
End Sub

下面我们通过一个实例来讲解,把成绩小于60分的提取出来

第一种解法,利用工作表函数Countif来判断不及格的人数
Sub 提取二()
Dim arr1, arr2(), y%, x%, z%, k%
Sheets(1).Activate
arr1 = Range("A1").CurrentRegion '把数据装到数组arr1里
y = Application.WorksheetFunction.CountIf(Range("B2:B" & UBound(arr1, 1)), "<60")
'调用工作表函数countif统计出B列小于60分个数
ReDim arr2(1 To y, 1 To UBound(arr1, 2)) '重新定义数组arr2的空间大小
For x = 1 To UBound(arr1, 1) '循环数组arr1的行
      If arr1(x, 2) < 60 Then '判断arr1(x,2)如果小于60,那么
         k = k + 1 '累加k
         For z = 1 To UBound(arr1, 2) '把满足条件从数组arr1装到数组arr2里
            arr2(k, z) = arr1(x, z) '把arr1的第x行z列装到arr2里第k行z列里
         Next z
      End If
Next x
Sheets(2).Cells = "" '读出来之前,把第二个工作表数据清空
With Sheets(2)
      .[A1].Resize(1, UBound(arr1, 2)) = arr1 ' 把表头读到第一行
      .[A2].Resize(k, UBound(arr1, 2)) = arr2 '把数组arr2读到单元格里
End With
Sheets(2).Select
End Sub

第二种解法利用Preserve保留原有值,不断的把满足要求装入数组,不过这只能是不断扩大其二维大小,所以我们最后还要通过转置函数Transpose一下
Option Explicit
Sub test() '用动态数组的解法()
Dim arr1, arr2(), x&, k& '把数组定义动态数组
Sheets(1).Activate
arr1 = Range("A1").CurrentRegion '把数据装到数组arr1里
For x = 1 To UBound(arr1, 1) '循环数组arr1的行
'ubound函数取得数组的最后索引号,UBound(arr1, 1)取得行索引号最大值
'UBound(arr1, 1)取得列索引号最大值,有的叫做下标
      If arr1(x, 2) < 60 Then '如果分数小于60,那么
         k = k + 1 '累加k
         ReDim Preserve arr2(1 To 3, 1 To k)
         '重新定义arr2的空间结构,且保留原有值
         arr2(1, k) = arr1(x, 1) '把数组arr1的第x行第1列
         '装到arr2里的第1行第k列
         arr2(2, k) = arr1(x, 2)
         arr2(3, k) = arr1(x, 3)
      End If
Next x
Sheets(2).Cells = "" '读出来之前,把第二个工作表数据清空
With Sheets(2)
      .[A1].Resize(1, UBound(arr1, 2)) = arr1 ' 把表头读到第一行
      .[A2].Resize(k, UBound(arr1, 2)) = Application.Transpose(arr2)
      '为什么还要转置呢?
      '因为数组2是不断的扩展二维,也不是列
End With
Sheets(2).Select
End Sub
Sub 清空()
Sheets(2).Cells = "" '读出来之前,把第二个工作表数据清空
End Sub

第三种解法,先定义一个足够大的数组空间,用来装小于60分的记录

Sub 提取三()
Dim arr1, arr2(), y%, x%, z%, k%
Sheets(1).Activate
arr1 = Range("A1").CurrentRegion '把数据装到数组arr1里
ReDim arr2(1 To 10000, 1 To UBound(arr1, 2)) '首先给数组arr2一个足够大的空间用来存放数据
For x = 1 To UBound(arr1, 1) '循环数组arr1的行
      If arr1(x, 2) < 60 Then '判断arr1(x,2)如果小于60,那么
         k = k + 1 '累加k
         For z = 1 To UBound(arr1, 2) '把满足条件从数组arr1装到数组arr2里
            arr2(k, z) = arr1(x, z) '把arr1的第x行z列装到arr2里第k行z列里
         Next z
      End If
Next x
Sheets(2).Cells = "" '读出来之前,把第二个工作表数据清空
With Sheets(2)
      .[A1].Resize(1, UBound(arr1, 2)) = arr1 ' 把表头读到第一行
      .[A2].Resize(k, UBound(arr1, 2)) = arr2 '把数组arr2读到单元格里
End With
Sheets(2).Select
End Sub

佛山小老鼠 · 发表于 2013-11-13 00:20

本帖最后由佛山小老鼠于 2013-11-17 02:47 编辑

数组里常用的函数

1.LBound 取得数组的上标

这个用的比较少,因为上标默认的是0和1

2.Ubound取得数组的下标

这个函数很多,不过大家要注意对一维数组来说,只有一个下标如 ubound(arr1)和ubound(arr1,1)是一样的
而对二维数组来说,就有二个下标了.一个是行,也就是说一维的下标,一个是列,是二维的下标
一维上的下标 ubound(arr1)和Ubound(arr1,1) 是一样的,而二维上的下标 Ubound(arr1,2)

3.Split:按照某一字符串拆分成一个一维数组,且上标从0开始

Sub Split的用法1() 'Split生成数组是一维的，且最小索引是从0开始的
Dim arr1
arr1 = VBA.Split(Range("A1"), ",")
[C1].Resize(1, UBound(arr1, 1) + 1) = arr1 '为什么要加1，因为最小上标是从0开始，所以加1
End Sub
Sub Split的用法2() 'Split生成数组是一维的，且最小索引是从0开始的
Dim arr1
arr1 = VBA.Split(Range("A1"), ",")
[C3].Resize(UBound(arr1, 1) + 1, 1) = Application.WorksheetFunction.Transpose(arr1) '为什么要加1，因为最小上标是从0开始，所以加1
End Sub

4.Join:按照某一字符串把一个一维数组合并成一串字符

Option Explicit
Sub Jion的用法1() '大家记得函数Jion第一参数的数组只能是一维的
Dim MaxRow%, arr1, arr2
MaxRow = Cells(Rows.Count, 1).End(xlUp).Row
arr1 = Range("A1:A" & MaxRow)
arr2 = Application.WorksheetFunction.Transpose(arr1)
[B1] = VBA.Join(arr2, ",")
End Sub
Sub Jion的用法2()
Dim MaxColumn%, arr1, arr2, arr3
MaxColumn = Cells(1, Columns.Count).End(xlToLeft).Column
arr1 = Range(Cells(1, 1), Cells(1, MaxColumn))
' arr2 = Application.WorksheetFunction.Transpose(arr1)’把二维的横向转为二维纵向数组
' arr3 = Application.WorksheetFunction.Transpose(arr2)’再把二维的纵向数组转为一维的横向数组
arr3 = Application.Transpose(Application.Transpose(arr1)) '可以省略WorksheetFunction
[AB2] = VBA.Join(arr3, "")
End Sub

5.InStr.找到一个字符串在另一字串中的位置,有点像工作簿函数的Find函数,它比Find函数还好用,因为它如果找不出就返回0,不会报错

Sub Instr的用法()
'InStr相当于工作表内置函数Find
'VBA.InStr(从要那一串字符串中找,要找的字符串
'作用是返加这个要找的字符串在那一串字符串的位置
'如果找不到就返回0
Dim arr1, arr2(1 To 100, 1 To 2), x%, k%
arr1 = Sheets(6).UsedRange
Range("D1:F1048576") = ""
For x = 2 To UBound(arr1, 1)
      If VBA.InStr(arr1(x, 1), "李") <> 0 Then
         k = k + 1
         arr2(k, 1) = arr1(x, 1)
         arr2(k, 2) = arr1(x, 2)
      End If
Next x
[D1:E1] = Array("名称", "数量")
[D2].Resize(k, 2) = arr2
End Sub

'总结一下,InStr函数方便一些，不用转一维

6.InStrRev和I民InStr相反,默认找到一个,而InStrRev找最后一个

Sub InStrRev用法() '从st里提取工作簿名称
Dim st$, x%
st = "E:\桌面\VBA入门进阶36讲视频\X第二十四讲数组实战二\数组.xls"
x = InStrRev(st, "\") '找到最后一个"\" 的位置
MsgBox Right(st, Len(st) - x)
End Sub

7.Filter:从一个一维数组中筛选满足条件的

Sub Filter的用法()
Dim MaxRow%, arr1, arr2, arr3
MaxRow = Cells(Rows.Count, 1).End(xlUp).Row
arr1 = Range("A2:A" & MaxRow)
arr2 = Application.WorksheetFunction.Transpose(arr1)
arr3 = VBA.Filter(arr2, "李", True) '如果你筛选不包含“李”字的，那么就把True改为False
[C1] = "名称"
[C2].Resize(UBound(arr3, 1) + 1, 1) = Application.WorksheetFunction.Transpose(arr3)
End Sub

8.调用工作表内置函数Index

Sub Index的用法()
Dim MaxRow&, arr1, x%
MaxRow = Cells(Rows.Count, 1).End(xlUp).Row
arr1 = Range("A2:E" & MaxRow)
For x = 1 To UBound(arr1, 1)
      If arr1(x, 4) < 2000 Then
         arr1(x, 5) = "偏低"
      End If
Next x
[E1] = "备注"
'这里注意一下，以后我们在学函数时，Index第二参数可以省略，在VBA里大家要用0，不能省略，省略会报错
[E2].Resize(UBound(arr1, 1), 1) = Application.WorksheetFunction.Index(arr1, 0, 5)
End Sub

佛山小老鼠 · 发表于 2013-11-13 00:21

本帖最后由佛山小老鼠于 2013-11-17 00:57 编辑

多工作表查询

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False '关闭工作表事件
Sheets(1).Range("D5:F22") = "" '清空原有的数据
Dim x%, arr1, y%, MyStr$, arr2(1 To 100, 1 To 3)
Dim m%, n%, k%
MyStr = Sheets(1).Range("C5")
Application.ScreenUpdating = False '关闭屏幕刷新
For x = 2 To Sheets.Count '循环工作表,从第二个表开始
      arr1 = Sheets(x).UsedRange '把工作表区域装到数组arr1里
      For y = 2 To UBound(arr1, 1) '循环数组arr1的行
         If arr1(y, 2) = MyStr Then '把数组arr1第2列的满足条件装到数组arr2
            k = k + 1
            For m = 1 To 3
                  arr2(k, m) = arr1(y, m + 2)
            Next m
         End If
         If arr1(y, 7) = MyStr Then '把数组arr1第7列的满足条件装到数组arr2
            k = k + 1
            For n = 1 To 3
                  arr2(k, n) = arr1(y, n + 7)
            Next n
         End If
      Next y
Next x
Application.ScreenUpdating = True '打开屏幕刷新
On Error GoTo 100 '由于所有的表里一个也不找不到,报错,跳到100
Sheets(1).[D5].Resize(k, 3) = arr2 '把数组arr2读出来
Application.EnableEvents = True '打开工作表事件
Exit Sub
100:
Application.EnableEvents = True
MsgBox "亲，不好意思，各个表里查不到" & MyStr, 64, "温馨提示——佛山小老鼠"
End Sub

佛山小老鼠 · 发表于 2013-11-13 00:22

本帖最后由佛山小老鼠于 2013-11-17 02:17 编辑

多工作簿查询

先申请,这个代码速度是很慢的,没有用SQL和ADO结合起来那么快,如果工作簿不是很多可以接受,呵呵,大约30个工作簿以下吧,多了可能让人等的太久,如果用SQL和ADO几秒就可以了

如果想速度很快,请参考 zhaogang1960 版主出的竞赛题:[Excel 程序开发] 【83期】VBA多工作簿多工作表数据查询[已小结]

http://club.excelhome.net/thread-781055-1-1.html

80多个工作簿2秒多查询完毕

Option Explicit

Sub 查询()
Dim MyFile$, Wb As Workbook, x%, Zlast%, st$, arr2(1 To 10000, 1 To 5), z%
Dim arr1, k%, j%
Range("A2:F" & Rows.Count) = "" '清空原有的数据
MyFile = Dir(ThisWorkbook.Path & "\分表\*.*") '取得分表文件夹下任意一个文件名
st = ThisWorkbook.Sheets(1).[A1]
Do '循环文件夹里的文件
Set Wb = GetObject(ThisWorkbook.Path & "\分表\" & MyFile) '在后台打开工作簿且赋值给变量Wb
With Wb
      For x = 1 To Wb.Sheets.Count '循环打开的工作簿里的工作表
         arr1 = .Sheets(x).Range("A1").CurrentRegion.Offset(1) '把工作表区域数据装到数组arr1里
         For j = 1 To UBound(arr1, 1) '循环数组arr1里的行
            If arr1(j, 1) = st Then '判断是否和查询值相等
                  k = k + 1
                  For z = 2 To 6
                     arr2(k, z - 1) = arr1(x, z) '把数组arr1满足条件装到数组arr2里
                  Next z
            End If
         Next j
      Next x
      .Close True '关闭wb工作簿
End With
MyFile = Dir '第二次赋值不要参数,且自动找到下一个工作簿
Loop While MyFile <> ""
[B2].Resize(k, 5) = arr2 '把数组arr2读出来
End Sub

佛山小老鼠 · 发表于 2013-11-13 00:23

本帖最后由佛山小老鼠于 2013-11-17 00:45 编辑

找出两列相同项与不相同项及两列共有

Option Explicit
Sub 对比两列()
Dim LastA, LastB, arrA, arrB
Dim x&, y&, k&, arr1(1 To 100, 1 To 1), arr2(1 To 100, 1 To 1), arr3(1 To 100, 1 To 1)
Dim s&, m%, a&, b&, c&, n&, dic1, dic2, dic3, x1, x2&, x3&
Set dic1 = CreateObject("Scripting.dictionary")
Set dic2 = CreateObject("Scripting.dictionary")
Set dic3 = CreateObject("Scripting.dictionary")
Application.ScreenUpdating = False
LastA = Sheets("两列数据对比").Cells(Rows.Count, 1).End(xlUp).Row
LastB = Sheets("两列数据对比").Cells(Rows.Count, 2).End(xlUp).Row
arrA = Range("A1:A" & LastA)
arrB = Range("B1:B" & LastB)
For x = 1 To UBound(arrA, 1)
      For y = 1 To UBound(arrB, 1)
         If arrB(y, 1) = arrA(x, 1) Then
            k = k + 1
            s = s + 1
            arr1(k, 1) = arrA(x, 1) '把A列在B列有的装入数组arr1,共有的
            Exit For
         End If
      Next y
      If s = 0 Then
         m = m + 1
         arr2(m, 1) = arrA(x, 1) '把A列有的，B没有的装入数组arr2里
      End If
      s = 0 '为什么要归零，为了下一次判断
Next x
For b = 1 To UBound(arrB, 1)
      For a = 1 To UBound(arrA, 1)
         If arrA(a, 1) = arrB(b, 1) Then
            c = c + 1
            Exit For
         End If
      Next a
      If c = 0 Then
         n = n + 1
         arr3(n, 1) = arrB(b, 1) '把B列有的，A列没有装进数组arr3
      End If
      c = 0 '为什么要归零，为了下一次判断
Next b
For x1 = 1 To UBound(arr1, 1)
      If arr1(x1, 1) <> "" Then
         dic1(arr1(x1, 1)) = "" '字典dic1有去重作用, 把A列里重复的去掉
      End If
Next x1
For x2 = 1 To UBound(arr2, 1)
      If arr2(x2, 1) <> "" Then
         dic2(arr2(x2, 1)) = "" '字典dic2有去重作用, 把A列里重复的去掉
      End If
Next x2
For x3 = 1 To UBound(arr3, 1)
      If arr3(x3, 1) <> "" Then
         dic3(arr3(x3, 1)) = "" '字典dic3有去重作用, 把B列里重复的去掉
      End If
Next x3
On Error Resume Next
Application.DisplayAlerts = False
Sheets("两列对比后的结果").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Sheets.Add after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = "两列对比后的结果"
With Sheets("两列对比后的结果")
      .[A1] = "在A列有B列没有"
      .[B1] = "在B列有A列没有"
      .[C1] = "A列和B列都有的"
      .[A2].Resize(dic2.Count, 1) = Application.WorksheetFunction.Transpose(dic2.keys)
      .[B2].Resize(dic3.Count, 1) = Application.WorksheetFunction.Transpose(dic3.keys)
      .[C2].Resize(dic1.Count, 1) = Application.WorksheetFunction.Transpose(dic1.keys)
.Columns("A:C").EntireColumn.AutoFit
End With
   Application.ScreenUpdating = True
End Sub

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

[原创] 佛山小老鼠带您走进VBA数组(菜鸟请进)

评分

评分

评分

评分