ReDimPreserve

loquat

ReDim Preserve 二维数组是不可以的，偶然玩一下，写了这么个函数

1. Public Sub ReDimPreserve(arrPreserve, ByVal end_row2&, ByVal end_col2&, Optional ByVal start_row2, Optional ByVal start_col2)
   
2. '功能：突破ReDim Preserve不能处理二维数组的限制
   
3. '参数1：arrPreserve待重置的数组
   
4. '参数2：end_row2
   
5. '参数3：end_col2
   
6. '参数4：start_row2，可选，默认为原始数组第1维下标
   
7. '参数5：start_col2，可选，默认为原始数组第2维下标
   
8. '注意：1、未对上下标参数的大小做判断，请自行注意
   
9.     Dim arrTemp As Variant
   
10.     Dim i As Long, j As Long
    
11.     Dim start_row1 As Long, end_row1 As Long
    
12.     Dim start_col1 As Long, end_col1 As Long
    
13.     If Not IsArray(arrPreserve) Then Exit Sub
    
14.     start_row1 = LBound(arrPreserve, 1)
    
15.     end_row1 = UBound(arrPreserve, 1)
    
16.     start_col1 = LBound(arrPreserve, 2)
    
17.     end_col1 = UBound(arrPreserve, 2)
    
18.     If VarType(start_row2) = 10 Then start_row2 = start_row1   '设置默认下标，vbError = 10
    
19.     If VarType(start_col2) = 10 Then start_col2 = start_col1   '设置默认下标
    
20.     ReDim arrTemp(start_row2 To end_row2, start_col2 To end_col2)
    
21.     If start_row2 > end_row1 Or _
    
22.        end_row2 < start_row1 Or _
    
23.        start_col2 > end_col1 Or _
    
24.        end_col2 < start_col1 Then   '容错判断，新数组完全不在原始数组上下标范围内
    
25.         Err.Raise 0, "ReDimPreserve", "上标或下标超出原始范围"
    
26.         Exit Sub
    
27.     Else  '至少包含了原始数组的一部分
    
28.         If start_row2 > start_row1 Then start_row1 = start_row2
    
29.         If start_col2 > start_col1 Then start_col1 = start_col2
    
30.         If end_row2 < end_row1 Then end_row1 = end_row2
    
31.         If end_col2 < end_col1 Then end_col1 = end_col2
    
32.         For i = start_row1 To end_row1       '以修正后的原始数组上下标范围复制数据
    
33.             For j = start_col1 To end_col1
    
34.                 arrTemp(i, j) = arrPreserve(i, j)  '复制数据
    
35.             Next
    
36.         Next
    
37.         arrPreserve = arrTemp   '传址方式返回
    
38.     End If
    
39. End Sub

复制代码

不同于ReDim Preserve语句，这个函数会对上下标做截断处理，而不是像前者那样，直接改变上下标本身。
使用示例：

1. Sub Test()
   
2.     Dim arr
   
3.     ReDim arr(1 To 4, 1 To 4)
   
4.     Dim i&, j&
   
5.     For i = 1 To 4
   
6.         For j = 1 To 4
   
7.             arr(i, j) = i & "-" & j
   
8.         Next j
   
9.     Next i
   
10.     ReDimPreserve arr, 3, 3, 0, 0
    
11.     ReDimPreserve arr, 3, 3, 2, 2
    
12. End Sub

复制代码

zhanglei1371

这么牛叉爆棚的帖子，能看懂的人，绝对不多

loquat

这完全不能称作牛叉啊，就是个基础再基础不过的函数。