兼具Index、Redim、Transpose多功能的数组处理自定义函数

香川群子

1. Function Index2(trr, Optional r = 0, Optional c = 0, Optional k = 0, Optional h& = -1, Optional w& = -1)
   
2.     If r And h = -1 Then
   
3.         If c = 0 Then c = LBound(trr, 2)
   
4.         If k = "" Then kc = c Else kc = k
   
5.         c2 = UBound(trr, 2)
   
6.         If w > 0 Then If c + w - 1 < c2 Then c2 = c + w - 1
   
7.         ReDim tr(kc To c2 - c + kc)
   
8.         For j = c To c2
   
9.             tr(j - c + kc) = trr(r, j)
   
10.         Next
    
11.         Index2 = tr
    
12.     ElseIf c And w = -1 Then
    
13.         If r = 0 Then r = LBound(trr)
    
14.         If k = "" Then kr = r Else kr = k
    
15.         r2 = UBound(trr)
    
16.         If h > 0 Then If r + h - 1 < r2 Then r2 = r + h - 1
    
17.         ReDim tr(kr To r2 - r + kr)
    
18.         For i = r To r2
    
19.             tr(i - r + kr) = trr(i, c)
    
20.         Next
    
21.         Index2 = tr
    
22.     Else
    
23.         If r = 0 Then r = LBound(trr)
    
24.         If c = 0 Then c = LBound(trr, 2)
    
25.         If k = "" Then
    
26.             kr = r: kc = c
    
27.         ElseIf k Like "T*" Then
    
28.             If k = "T" Then
    
29.                 kr = r: kc = c
    
30.             Else
    
31.                 kr = Val(Mid(k, 2)): kc = kr
    
32.             End If
    
33.         Else
    
34.             kr = k: kc = k
    
35.         End If
    
36.         If h > 0 Then r2 = r + h - 1 Else r2 = UBound(trr)
    
37.         If w > 0 Then c2 = c + w - 1 Else c2 = UBound(trr, 2)
    
38.         
    
39.         If k Like "T*" Then
    
40.             ReDim tr2(kc To c2 - c + kc, kr To r2 - r + kr)
    
41.             If r2 > UBound(trr) Then r2 = UBound(trr)
    
42.             If c2 > UBound(trr, 2) Then c2 = UBound(trr, 2)
    
43.             For i = r To r2
    
44.                 For j = c To c2
    
45.                     tr2(j - c + kc, i - r + kr) = trr(i, j)
    
46.                 Next
    
47.             Next
    
48.         Else
    
49.             ReDim tr2(kr To r2 - r + kr, kc To c2 - c + kc)
    
50.             If r2 > UBound(trr) Then r2 = UBound(trr)
    
51.             If c2 > UBound(trr, 2) Then c2 = UBound(trr, 2)
    
52.             For i = r To r2
    
53.                 For j = c To c2
    
54.                     tr2(i - r + kr, j - c + kc) = trr(i, j)
    
55.                 Next
    
56.             Next
    
57.         End If
    
58.         Index2 = tr2
    
59.     End If
    
60. End Function
    

复制代码

hyqzzs

佩服、膜拜

liucqa

文档呢？

或者你把代码改成自文档化也行

如果没文档也不能自文档化，那就把注释写上吧，要不太坑了

看着一大堆 r、c、k、h、w、kc、c2之类的，鬼画符也不过如此呀

香川群子

该自定义函数，首先具有Index(arr,i,j)这样从数组中提取任意行、列得到新数组的功能，
但功能更强大：

一、Index数组提取功能：
1. 可以提取多行、多列得到二维数组
同时也能根据需要返回一维数组结果 （而Index函数只能得到指定某行、或指定某列的单一的一维数组）

2. 也可以只提取某些行、某些列中的部分行、部分列。（默认提取整行、整列）


二、数组Redim功能：
指定行数、列数以后，当然就可以直接得到新的不同行数、列数的新数组了。
尤其重要的是：可以同时扩展/缩小行数以及列数，而Redim函数只能处理最后一维(二维数组中的第2维)

当然，有一个缺点是：
我的自定义函数目前只能处理一维和二维数组，不包括三维以上的多维数组。（因为无实用性，所以不弄了）

三、数组Transpose转置功能：
使用"T"参数就可以进行二维数组的转置了。

其它：
新数组的下标起始值，可以定义修改。

如原来是arr(1, 1)开始的二维数组，
可以转换为arr(0, 0)开始的二维数组，或转换为arr(2, 2)开始、或arr(-1, -1)开始的新的二维数组。

目前行列的开始值都是相同的……没有考虑不同的情形。
但是也可以选择默认采用原数组起始值作为新数组的开始，
如选择从 arr(2,3)开始提取数据，并得到arr(2,3)开始的数组。（或设置为arr(0, 0)、arr(1, 1)等）



下面是部分应用实例：

1. Sub test()
   
2.     arr = [a1:e10]
   
3.     ar11 = Index2(arr, 3)
   
4.     ar12 = Index2(arr, 3, , 1)
   
5.     ar13 = Index2(arr, 3, , 2)
   
6.     ar14 = Index2(arr, 3, , "")
   
7.     ar15 = Index2(arr, 3, , 0, -1)
   
8.     ar16 = Index2(arr, 3, , "", -1)
   
9.     ar17 = Index2(arr, 3, , 3, -1)
   
10.    
    
11.     ar18 = Index2(arr, 3, , , 1)
    
12.     ar19 = Index2(arr, 3, , 1, 1)
    
13.    
    
14.     ar21 = Index2(arr, 3, 2)
    
15.     ar22 = Index2(arr, 3, 2, "", 1, 0)
    
16.     ar23 = Index2(arr, 3, 2, "", 1, 3)
    
17.    
    
18.     ar24 = Index2(arr, 3, 2, , 5, 4)
    
19.     ar25 = Index2(arr, 3, 2, 1)
    
20.     ar26 = Index2(arr, 3, 2, 0, 5, 4)
    
21.     ar27 = Index2(arr, 3, 2, 1, 5, 4)
    
22.     ar28 = Index2(arr, 3, 2, "", 5, 4)
    
23.    
    
24.     ar30 = Index2(arr, 3, 2, , 1, 1)
    
25.     ar31 = Index2(arr, 3, 2, 1, 1, 1)
    
26.    
    
27.     ar40 = Index2(arr, , 2)
    
28.     ar41 = Index2(arr, , 2, , 5)
    
29.     ar42 = Index2(arr, 3, 2, , 5)
    
30.    
    
31.     ar50 = Index2(arr)
    
32.     ar51 = Index2(arr, , , "")
    
33.     ar52 = Index2(arr, , , "T")
    
34.     ar53 = Index2(arr, , , "T0")
    
35.    
    
36.     ar60 = Index2(arr, , , , UBound(arr) + 5, UBound(arr, 2) + 3)
    
37.     ar61 = Index2(arr, , , "T", UBound(arr) + 5, UBound(arr, 2) + 3)
    
38.     ar62 = Index2(arr, , , "T2", UBound(arr) + 5, UBound(arr, 2) + 3)
    
39.     Stop
    
40. End Sub

复制代码

℡Soul

x想说明什么

香川群子

liucqa 发表于 2014-7-9 12:50
文档呢？

或者你把代码改成自文档化也行

呵呵，自娱自乐而已，没想着要把这个函数真正当做能被广泛使用、代替现存函数功能的实用函数。

文字说明下面4楼已经有了，但也只是简单功能说明，
对实际函数的使用，感觉也比较繁琐，意义不是特别大。

如果有希望了解数组计算方法的人提问，我会考虑做相应说明的。

香川群子

函数参数结构，更像Offset函数的参数。

如：=Offset([参照范围],[行起始],[列起始],[行高],[列宽])

而我的自定义函数参数是：
=Index2([数组trr], [行位置r],[列位置c],[新起始位置以及模式],[行高],[列宽])

多了个新起始位置以及模式的 k参数而已。

百度不到去谷歌

liucqa 发表于 2014-7-9 12:50
文档呢？

或者你把代码改成自文档化也行

哈哈 这是香川写代码的风格 力求精简
不过这个函数还是很多地方能用的 赞一个 希望多多出这样的精品
提取多行多列的还有转置 是比较常用的 论坛问题常有这样的需求
因为系统只能单行单列提取 然后系统的转置有255字符限制

香川群子

今天抽时间先把代码整出来了，注释、解释还没有时间搞。

嗯，过几天有时间再详细解释，顺便尝试一下变量命名标准化 （自文档化）

然后再上附件，把各种应用好好说明一下。

香川群子

上附件。

1. Function Index2(trr_Array_Area, Optional r_RowIndex = 0, Optional c_ColumnIndex = 0, Optional k_LBound_Transpose = 0, Optional h_RowHeight& = -1, Optional w_ColumnWidth& = -1)
   
2.     Rem 兼具 Index数组提取、数组Redim、数组Transpose转置 三大功能的 自定义函数
   
3.    
   
4.     Rem Index除可提取整行、整列外 更可提取任意行列位置起始的多行多列矩形局域 并可任意设置数组下标开始值(或保留原始值)
   
5.    
   
6.     Rem Redim则很简单 Index提取时按需要重新设置行高、列宽即可 优点是可以同时设置二维数组的2个维度 而标准Redim只能修改第2维的大小
   
7.    
   
8.     Rem Transpose同样简单 但由于兼具上述特点而更强大 1.任意行列位置开始 2.任意二维大小Redim 3.无65536限制
   
9.    
   
10.     Rem 第1参数trr_Array_Area： 为引用的VBA内存一维或二维数组如arr 或[工作表区域].Value的二维结构数组
    
11.     Rem 第2、3参数r_RowIndex 和 第3参数c_ColumnIndex：可省略。默认值=0即整行、整列，否则为数组起点开始的行、列相对位置
    
12.     Rem 第4参数k_LBound_Transpose：
    
13.     Rem     该参数可省略。 默认值=0即设置新数组起点开始LBound=0 否则如果是数值则按指定数值开始 数值应该是含0整数
    
14.     Rem     该参数为空值=""时 按原数组指定行列开始的位置作为新数组起点开始的LBound值
    
15.     Rem     该参数首字母="T"时 除Index、Redim功能外 还对数组结果进行Transpose的行列转置 但转置结果仍是二维数组
    
16.     Rem     该参数首字母="T"时 其后的数值仍可作为新数组起点开始的LBound值 因此="T"时相当于="T0"则新数组起点开始LBound=0
    
17.     Rem 第5、6参数h_RowHeight 和 w_ColumnWidth：该参数可省略。 默认值=-1即输出一维数组 否则按指定值进行多行、多列的二维数组输出
    
18.    
    
19.     Dim r1_RowStart&, c1_ColumnStart&, r2_RowEnd&, c2_ColumnEnd&, kr_RowLBound&, kc_ColumnLBound&, i_RowCount&, j_ColumnCount&, d_OneDimensionArray&
    
20.         
    
21.     On Error GoTo 1
    
22.     c1_ColumnStart = LBound(trr_Array_Area, 2)
    
23.    
    
24.     If r_RowIndex = 0 Then r1_RowStart = LBound(trr_Array_Area) Else r1_RowStart = LBound(trr_Array_Area) + r_RowIndex - 1
    
25.     If c_ColumnIndex = 0 Then c1_ColumnStart = LBound(trr_Array_Area, 2) Else c1_ColumnStart = LBound(trr_Array_Area, 2) + c_ColumnIndex - 1
    
26.     GoTo 2
    
27. 1
    
28.     d_OneDimensionArray = 1
    
29.     If r_RowIndex = 0 Then c1_ColumnStart = 0 Else If c_ColumnIndex = 0 Then c_ColumnIndex = r_RowIndex: r_RowIndex = 0
    
30.     If c_ColumnIndex = 0 Then r1_RowStart = LBound(trr_Array_Area) Else r1_RowStart = LBound(trr_Array_Area) + c_ColumnIndex - 1
    
31. 2
    
32.     If r_RowIndex > 0 And h_RowHeight = -1 Then
    
33.         If k_LBound_Transpose = "" Then kc_ColumnLBound = c1_ColumnStart Else kc_ColumnLBound = k_LBound_Transpose
    
34.         If d_OneDimensionArray = 0 Then c2_ColumnEnd = UBound(trr_Array_Area, 2)
    
35.         If w_ColumnWidth > 0 Then If c1_ColumnStart + w_ColumnWidth - 1 < c2_ColumnEnd Then c2_ColumnEnd = c1_ColumnStart + w_ColumnWidth - 1
    
36.         ReDim tr_Output(kc_ColumnLBound To c2_ColumnEnd - c1_ColumnStart + kc_ColumnLBound)
    
37.         For j_ColumnCount = c1_ColumnStart To c2_ColumnEnd
    
38.             tr_Output(j_ColumnCount - c1_ColumnStart + kc_ColumnLBound) = trr_Array_Area(r1_RowStart, j_ColumnCount)
    
39.         Next
    
40.         Index2 = tr_Output
    
41.     ElseIf c_ColumnIndex > 0 And w_ColumnWidth = -1 Then
    
42.         If k_LBound_Transpose = "" Then kr_RowLBound = r1_RowStart Else kr_RowLBound = k_LBound_Transpose
    
43.         r2_RowEnd = UBound(trr_Array_Area)
    
44.         If h_RowHeight > 0 Then If r1_RowStart + h_RowHeight - 1 < r2_RowEnd Then r2_RowEnd = r1_RowStart + h_RowHeight - 1
    
45.         ReDim tr_Output(kr_RowLBound To r2_RowEnd - r1_RowStart + kr_RowLBound)
    
46.         If d_OneDimensionArray = 1 Then
    
47.             For i_RowCount = r1_RowStart To r2_RowEnd
    
48.                 tr_Output(i_RowCount - r1_RowStart + kr_RowLBound) = trr_Array_Area(i_RowCount)
    
49.             Next
    
50.         Else
    
51.             For i_RowCount = r1_RowStart To r2_RowEnd
    
52.                 tr_Output(i_RowCount - r1_RowStart + kr_RowLBound) = trr_Array_Area(i_RowCount, c1_ColumnStart)
    
53.             Next
    
54.         End If
    
55.         Index2 = tr_Output
    
56.     Else
    
57.         If k_LBound_Transpose = "" Then
    
58.             kr_RowLBound = r1_RowStart: kc_ColumnLBound = c1_ColumnStart
    
59.         ElseIf k_LBound_Transpose Like "T*" Then
    
60.             If k_LBound_Transpose = "T" Then
    
61.                 kr_RowLBound = r1_RowStart: kc_ColumnLBound = c1_ColumnStart
    
62.             Else
    
63.                 kr_RowLBound = Val(Mid(k_LBound_Transpose, 2)): kc_ColumnLBound = kr_RowLBound
    
64.             End If
    
65.         Else
    
66.             kr_RowLBound = k_LBound_Transpose: kc_ColumnLBound = k_LBound_Transpose
    
67.         End If
    
68.         If h_RowHeight > 0 Then r2_RowEnd = r1_RowStart + h_RowHeight - 1 Else r2_RowEnd = UBound(trr_Array_Area)
    
69.         If d_OneDimensionArray = 0 Then If w_ColumnWidth > 0 Then c2_ColumnEnd = c1_ColumnStart + w_ColumnWidth - 1 Else c2_ColumnEnd = UBound(trr_Array_Area, 2)
    
70.         
    
71.         If k_LBound_Transpose Like "T*" Then
    
72.             ReDim tr2_Output(kc_ColumnLBound To c2_ColumnEnd - c1_ColumnStart + kc_ColumnLBound, kr_RowLBound To r2_RowEnd - r1_RowStart + kr_RowLBound)
    
73.             If r2_RowEnd > UBound(trr_Array_Area) Then r2_RowEnd = UBound(trr_Array_Area)
    
74.             If d_OneDimensionArray = 0 Then If c2_ColumnEnd > UBound(trr_Array_Area, 2) Then c2_ColumnEnd = UBound(trr_Array_Area, 2)
    
75.             If d_OneDimensionArray = 1 Then
    
76.                 For i_RowCount = r1_RowStart To r2_RowEnd
    
77.                     tr2_Output(j_ColumnCount - c1_ColumnStart + kc_ColumnLBound, i_RowCount - r1_RowStart + kr_RowLBound) = trr_Array_Area(i_RowCount)
    
78.                 Next
    
79.             Else
    
80.                 For i_RowCount = r1_RowStart To r2_RowEnd
    
81.                     For j_ColumnCount = c1_ColumnStart To c2_ColumnEnd
    
82.                         tr2_Output(j_ColumnCount - c1_ColumnStart + kc_ColumnLBound, i_RowCount - r1_RowStart + kr_RowLBound) = trr_Array_Area(i_RowCount, j_ColumnCount)
    
83.                     Next
    
84.                 Next
    
85.             End If
    
86.         Else
    
87.             ReDim tr2_Output(kr_RowLBound To r2_RowEnd - r1_RowStart + kr_RowLBound, kc_ColumnLBound To c2_ColumnEnd - c1_ColumnStart + kc_ColumnLBound)
    
88.             If r2_RowEnd > UBound(trr_Array_Area) Then r2_RowEnd = UBound(trr_Array_Area)
    
89.             If d_OneDimensionArray = 0 Then If c2_ColumnEnd > UBound(trr_Array_Area, 2) Then c2_ColumnEnd = UBound(trr_Array_Area, 2)
    
90.             If d_OneDimensionArray = 1 Then
    
91.                 For i_RowCount = r1_RowStart To r2_RowEnd
    
92.                     tr2_Output(i_RowCount - r1_RowStart + kr_RowLBound, j_ColumnCount - c1_ColumnStart + kc_ColumnLBound) = trr_Array_Area(i_RowCount)
    
93.                 Next
    
94.             Else
    
95.                 For i_RowCount = r1_RowStart To r2_RowEnd
    
96.                     For j_ColumnCount = c1_ColumnStart To c2_ColumnEnd
    
97.                         tr2_Output(i_RowCount - r1_RowStart + kr_RowLBound, j_ColumnCount - c1_ColumnStart + kc_ColumnLBound) = trr_Array_Area(i_RowCount, j_ColumnCount)
    
98.                     Next
    
99.                 Next
    
100.             End If
     
101.         End If
     
102.         Index2 = tr2_Output
     
103.     End If
     
104. End Function

复制代码