ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 110354|回复: 236

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

  [复制链接]

TA的精华主题

TA的得分主题

发表于 2013-11-13 00:13 | 显示全部楼层 |阅读模式
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
本帖已被收录到知识树中,索引项:数组集合和字典
本帖最后由 佛山小老鼠 于 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数组,也是篇幅有限,写的不详细,对手我这样菜鸟,也只能望“书”兴叹了,后来在论坛上找到了这几个帖,建议新手下载学习一下
2.叶枫老师的《菜鸟谈VBA最最基础入门原创http://club.excelhome.net/thread-470603-1-1.html

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



也许你不知道当时我在完美工具箱写的源代码,你看了一定会笑,为什么呢?因为我大部程序都是读取对象完成的,所以早期许多版本一些程序运行会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



附件.rar

316.09 KB, 下载次数: 2043

评分

7

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 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

1.jpg


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

2.jpg

同学位,我们从上面两段代码运行的速度可以明显看出,速度差异如些的大!大家说说,我们有必要学习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

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



速度对比.rar

91.18 KB, 下载次数: 884

简化代码.rar

16.48 KB, 下载次数: 806

TA的精华主题

TA的得分主题

 楼主| 发表于 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



图二.jpg



图三.jpg



图四.jpg




TA的精华主题

TA的得分主题

 楼主| 发表于 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

图一.jpg


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

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

图二.jpg

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

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

图三.jpg

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

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

图四.jpg


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

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

图五.jpg

总结一下:
老鼠老师问:"小白同学,这一节课你学会了没有?"
小白回答:老鼠老师,我这次没有晕,我想送给你一首歌"
老鼠老师说:什么歌?
小白回答:那我唱了,老师,“"最爱喝的水永远是黄河水,最爱说的话永远是中国话,最爱查的窗口永远是本地窗口”
老鼠老师说:谢谢小白同学的歌,老师知道您学会了这一节课,看您唱得那么开心。

单元格区域数据装入数组.rar

14.84 KB, 下载次数: 1006

评分

3

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 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

11.jpg




12.jpg


13.jpg



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

21.jpg


22.jpg


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

31.jpg

32.jpg


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

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



数据从数组里读出来.rar

26.14 KB, 下载次数: 933

评分

2

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2013-11-13 00:20 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
本帖最后由 佛山小老鼠 于 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





筛选小于60学生信息入在第二个表.rar

19.92 KB, 下载次数: 1269

评分

5

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 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

数组里常用的函数.rar

28.25 KB, 下载次数: 1103

TA的精华主题

TA的得分主题

 楼主| 发表于 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

多工作表查询.rar

44.69 KB, 下载次数: 1072

TA的精华主题

TA的得分主题

 楼主| 发表于 2013-11-13 00:22 | 显示全部楼层
本帖最后由 佛山小老鼠 于 2013-11-17 02:17 编辑

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

多工作簿查询.rar

52.12 KB, 下载次数: 963

TA的精华主题

TA的得分主题

 楼主| 发表于 2013-11-13 00:23 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
本帖最后由 佛山小老鼠 于 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

找出两项相同项与不同项.rar

22.48 KB, 下载次数: 1216

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-28 19:43 , Processed in 0.065927 second(s), 9 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表