http://www./study.asp?vip=10241777 资料学习的网址
''数组
''数组就是一个列或一组数据表
'数组存储在内存中 A.读写速度快 B.永远无法保存
''数组的分类 一般分为:1维 ,2维,3维 ....60维
Sub shuzuText()
Dim arr1(3) '4个 从0开始
Dim arr2(1 To 3) '3个 从1开始
Dim arr3(1 To 3, 1 To 2) '6个 3行2列
Dim arr4(3, 2) '12个 0-3 ，0-2 4行3列
End Sub
Sub text1()
Dim arr1(0 To 3)
arr2 = [{"A","B","C","D"}]
arr3 = Application.Transpose([{1;2;3;4}])
arr4 = [{"张","1";"王","2";"陈","3"}] ''' 用 ,号是隔列 用 ; 隔行
''array 公式
arr5 = Array(1, 2, 3, 4)
arr6 = Array(Array("a", "b"), Array(1, 2, 3))
End Sub
Sub 向数组中直接写入数据()
Dim arr(1 To 10)
arr(1) = "我"
arr(2) = "是"
arr(3) = "谁"
''数组循环写入()
Dim arr1(1 To 4)
Dim rng As Range
For Each rng In Range("a1:a3")
n = n + 1
arr1(n) = rng
Next
''写入一般数组
Dim arry() ''动态的
arry = Array("A", "B", "C")
End Sub
Sub 单元格区域数据批量写入数组()
''一行一列可转为一维数组 向数组中写入多行 是二维数组
arr = [a1:a3] ''竖向 二维数组 1,1 2,1 3,1
arr = Application.Transpose([a1:a3]) ''Transpose 转置为 一维数组
arr1 = [A1:C3] ''横向 1,1 1,2 1,3
arr1 = Application.Transpose([A1:C3]) ''先转为竖向
arr1 = Application.Transpose(Application.Transpose([A1:C3])) ''先转为竖向 再转为1维素数组
End Sub
Sub 取数组中指定的元素()
arr = [a1:a3]
a = arr(1, 1)
b = arr(2, 1)
End Sub
Sub 数组循环取值()
arr = [a1:A10] ''二维数组
[b1] = arr(2, 1)
For i = 1 To 8
Cells(i, 3) = arr(i, 1)
Next
End Sub
Sub 数组一次性赋值()
arr = [a1:a8]
Range("d1:d8") = arr
Range("d1:d" & 8) = arr
End Sub
Sub 用transpose函数转置()
arr = [a1:E1]
arr1 = Application.Transpose(arr) ''--横 变 竖
[a7:d7] = arr1 ''错误 :::已经变成竖列 只显示第一列内容
[F1:F7] = arr1 ''正常
''要注意两边的尺寸
End Sub
Sub 数组计算()
'在数组中求和 平均
arr = [a1:b5]
a = WorksheetFunction.Sum(arr) ''合
a = WorksheetFunction.Average(arr) ''平均
a = WorksheetFunction.Max(arr) ''最大
a = WorksheetFunction.Min(arr) ''最下
a = WorksheetFunction.Small(arr, 2) ''第2个最小的
a = WorksheetFunction.Large(arr, 2) ''第2个最大的
End Sub
Sub 数组实例()
Dim arr1(1 To 20) ''用于存储 数据
arr = [b2:c9]
For Each a In arr
If a > 80 Then
n = n + 1
arr1(n) = a ''存入数组
End If
Next
S = WorksheetFunction.Average(arr1)
End Sub
Sub 数组效率测试一般方法()
t = Timer
Set rng = Cells(Rows.Count, 1).End(xlUp) ''最后个单元格
arr = Range([a1], rng)
For Each a In arr
If a > 80 Then
n = n + 1
Cells(n, 3) = a
End If
Next
MsgBox Format(Timer - t, "0.0000") ''返回反应时间
End Sub
Sub 数组效率测试数组方法()
'Dim arr1(1 To 999)
Dim arr1(1 To 999, 1 To 1)
t = Timer
Set rng = Cells(Rows.Count, 1).End(xlUp)
arr = Range([a1], rng) ''数组写入
For Each a In arr
If a > 80 Then
n = n + 1
' arr1(n) = a ''将满足条件的赋值
arr1(n, 1) = a
End If
Next
'[d3].Resize(n) = Application.Transpose(arr1) ''转置
[d1].Resize(n, 1) = arr1
End Sub
Sub ULBound() '上界UBound 下界 LBound
Dim arr(4 To 8, 1 To 3, 1 To 9)
MsgBox UBound(arr, 1) ''第一维 的 上界
MsgBox LBound(arr, 1) ''第一维 的 下界
MsgBox UBound(arr, 2) ''第二维 的 上界
End Sub
Sub 利用数组提取不重复的值()
Dim arr1(1 To 10)
Set lastcell = Cells(Rows.Count, 1).End(xlUp)
arr = Range("a1", lastcell) ''将A列姓名存入数组
For i = 1 To lastcell.Row ''循环A列单元格 ''ubound(arr)
For j = 1 To UBound(arr1) ''用于记录 循环跟这个数组对比
X = arr(i, 1): y = arr1(j) ''辅助代码
If arr(i, 1) = arr1(j) Then
GoTo 100 ''有相等跳到下个循环
End If
Next
''
k = k + 1 ''用于累计
arr1(k) = arr(i, 1)
100:
Next
[e2].Resize(k) = Application.Transpose(arr1)
End Sub
Sub 利用数组提取不重复的值并计算()
Dim arr1(1 To 10, 1 To 2)
Set endr = Cells(Rows.Count, 1).End(xlUp)
arr = Range("b1", endr)
For i = 1 To endr.Row ''循环A列单元格
For j = 1 To UBound(arr1) ''空的 用于记录 找到arr1 数组的最大值,形成循环
X = arr(i, 1): y = arr1(j, 1) ''辅助代码
If arr(i, 1) = arr1(j, 1) Then ''循环判断单元格 是否等于 arr1
arr1(j, 2) = arr(i, 2) + arr1(j, 2) ''如果A列单元格 等于 arr1(j, 1) 将B列单元格的值 赋值给 arr1(j,1) 叠加
GoTo 100
End If
Next
k = k + 1 ''如果没有相等
arr1(k, 1) = arr(i, 1) ''把姓名,值 写入 arr1 数组
arr1(k, 2) = arr(i, 2)
100:
Next
[e2].Resize(k, 2) = arr1
End Sub
''有 Redim 重新申明 ,之后可以重新申明数组的上界,而不是一个估计的值
Sub Redim条件筛选实列()
Dim arr(), arr1()
rn = Cells(Rows.Count, 1).End(xlUp).Address
arr1 = Range("a1", rn) ''把区域单元格写入数组
m = WorksheetFunction.CountIf(Range("a2", rn), ">=80") ''统计区域内>=80的个数
ReDim arr(1 To m) ''重新确定数组上限
For Each ar In arr1
If ar >= 80 Then
n = n + 1
arr(n) = ar
End If
Next
[e1].Resize(UBound(arr)) = Application.Transpose(arr)
End Sub
Sub 数组重新定义保存()
Dim arr()
i = 9
arr = [{1,2,3}]
ReDim Preserve arr(1 To 5) ''重新定义数组 并保存之前的数组
ReDim Preserve arr(1 To 9)
ReDim arr(1 To 9)
End Sub
Sub 动态数组多表合并() ''利用数组汇总
Dim rng As Range
Dim arr()
For Each Sh In Sheets ''对工作簿进行循环
If Sh.Name <> "统计" Or Sh.Name <> "加密机密文件" Then
''Sh.UsedRange.Rows.Count 统计工作簿已使用的区域
arr1 = Sh.Range("A1:B" & Sh.UsedRange.Rows.Count) ''将工作簿数据区域赋值
act = act + UBound(arr1) ''累加各表的行 ,将作为重新声明arr1
ReDim Preserve arr(1 To 2, 1 To act) ''重新声明 arr 2行 X列
For j = 1 To UBound(arr1)
n = n + 1 ''汇总表累计
arr(1, n) = arr1(j, 1) ''arr1对应写入arr中
arr(2, n) = arr1(j, 2)
Next
End If
Next
Sheets("统计").Range("a1").Resize(n, 2) = Application.Transpose(arr)
End Sub
''
'' Split 函数(作用于1维数组)
'返回一个下标从零开始的一堆数组
Sub Splittext()
Dim i$
i = "a-b-c-d-e-f"
arr = Split(i, "-") '以横线为 拆分成一维数组
[a22].Resize(1, UBound(arr)) = arr
End Sub
Sub 数据互换()
[a1].CurrentRegion.Select
arr = [a1].CurrentRegion ''数组赋值
For Each a In arr ''对数组进行循环
arr1 = Split(a, "-")
n = n + 1
Cells(n, 3) = arr1(1) & "-" & arr1(0)
Next
End Sub
''join 函数作用于1维数组 返回字符串
Sub join数据合并()
i = Sheet4.Cells(Rows.Count, 1).End(xlUp).Row
For j = 1 To i
Set k = Range(Cells(j, 1), Cells(j, Columns.Count).End(xlToLeft))
arr = Application.Transpose(Application.Transpose(k))
Cells(j, 5) = "" & Join(arr, "")
Next
End Sub
''Filter 函数 filter(要搜索的1维数组,搜索的字符串,[True/False])
Sub filtertext() ''对数组内容进行筛选
arr = [{"abc","bb","c","ba","dd","nba"}]
a = filter(arr, "b", True) ''数组搜索 包含 "B"
a = filter(arr, "b", False) ''数组搜索 不包含 "B"
End Sub
''支持数组的函数 sumif ,countif,match,index ,vlookup
Sub indextext()
arr = [a2:C13]
arr1 = WorksheetFunction.Index(arr, 0, 2) ''取该数组的第2列 如行不为0形不成数组
arr2 = WorksheetFunction.Index(arr, 3, 0) ''去该数组的第3行
End Sub
Sub 查询系统()
[F1:n99].Clear
arr = Range("A1", Cells(Rows.Count, "c").End(xlUp))
For i = 1 To UBound(arr)
If arr(i, 1) Like [e1] Then ''
n = n + 1 '' 扩展一个区域用于存放数组
Cells(n, "i").Resize(1, 3) = WorksheetFunction.Index(arr, 1, 0) ''取该数组的行
End If
Next
End Sub
Sub VBAs数组格式化单元格()
Cells.ClearFormats ''清除格式
'arr = Range("c2:c" & Cells(Rows.Count).End(xlUp).Row) ''该列形成 数组
arr = Range("c2:c10") ''该列形成 数组
For i = 1 To UBound(arr)
If arr(i, 1) > 300 Then ''
Set rng = Cells(i + 1, "e").EntireRow.Range("a1:c1") ''第2列开始 取这整行
X = rng.Address
n = n + 1
If n = 1 Then
Set rngs = rng
Else
Set rngs = Union(rngs, rng) '单元格合并
y = rngs.Address
End If
End If
Next
rngs.Interior.ColorIndex = 9
End Sub
Sub 排序()
arr = Selection
For i = 1 To UBound(arr)
For j = i + 1 To undound ''单列相互对比
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
[g1].Resize(UBound(arr)) = arr
End Sub
Sub VBA数组分类汇总()
Dim arr1()
arr = Range("a2:c10") ''赋值区域
For i = 1 To UBound(arr)
ReDim Preserve arr1(1 To 2, 1 To n + 1)
For j = 1 To UBound(arr1, 2) '''求这个数组2维的上界
If arr1(1, j) = arr(i, 1) Then ''是否和arr 数组记录相等
arr1(2, j) = arr1(2, j) + arr(i, 2) '' 相等就相加
GoTo 100
End If
Next
n = n + 1
arr1(1, n) = arr(i, 1) ''如果arr1 不等于arr当前数组记录 则把当前的数组记录保存在arr1中
arr1(2, n) = arr(i, 2) ''第 X行 1,2 列 记录保存
100:
Next
[a15].Resize(n, 2) = Application.Transpose(arr1)
End Sub
