[已解决]求助，数组超限问题

scl5801

数组超限，请高手帮助

最佳答案

月排行榜 / 总排行榜

mxg825

2011-10-28 16:22

1. Sub mxzh() '明细统计
   
2.     Dim mxzh As Worksheet, pzqd As Worksheet
   
3.     Set mxzh = Worksheets("明细统计")
   
4.     Set pzqd = Worksheets("记工清单")
   
5.     Dim r_end%, x%, j%
   
6.     Dim i As Integer, r As Integer, arr(), arr1()
   
7.         r_end = pzqd.Cells(Rows.Count, 2).End(xlUp).Row
   
8.         arr = pzqd.Range("B5:r" & r_end)
   
9.         mxzh.Range("a7:s" & Rows.Count).Clear
   
10.       
    
11.         mxzh.Range("d4").Select
    
12.         i = 1
    
13.         j = 1
    
14.    With mxzh
    
15.         For r = 1 To UBound(arr, 1)
    
16.             If arr(r, 11) = Range("l4") And arr(r, 12) = Range("m4") Then
    
17.                 i = i + 1
    
18.                 ReDim Preserve arr1(1 To 17, 1 To i)
    
19.                     For l = 1 To 17
    
20.                         arr1(l, j) = arr(r, l)
    
21.                     Next l
    
22.                     j = j + 1
    
23. 
    
24.             Else
    
25.                If arr(r, 11) = Range("l4") And Range("m4") = 0 Then
    
26.                    i = i + 1
    
27.                    ReDim Preserve arr1(1 To 17, 1 To i)
    
28.                    For l = 1 To 17
    
29.                        arr1(l, j) = arr(r, l)
    
30.                     Next l
    
31.                     j = j + 1
    
32.                 End If
    
33.             End If
    
34.         Next r
    
35.         
    
36.            [b7].Resize(UBound(arr1, 2), 17) = Application.Transpose(arr1)
    
37.        End With
    
38.     End Sub

复制代码

跳转到最佳答案楼层

mxg825

ReDim Preserve arr1(1 To i, 1 To 17)
只能增加列，不能增加行！
ReDim Preserve arr1(1 To 17，1 To i )
最后把数组转置一下就可以了！

mxg825

1. Sub mxzh() '明细统计
   
2.     Dim mxzh As Worksheet, pzqd As Worksheet
   
3.     Set mxzh = Worksheets("明细统计")
   
4.     Set pzqd = Worksheets("记工清单")
   
5.     Dim r_end%, x%, j%
   
6.     Dim i As Integer, r As Integer, arr(), arr1()
   
7.         r_end = pzqd.Cells(Rows.Count, 2).End(xlUp).Row
   
8.         arr = pzqd.Range("B5:r" & r_end)
   
9.         mxzh.Range("a7:s" & Rows.Count).Clear
   
10.       
    
11.         mxzh.Range("d4").Select
    
12.         i = 1
    
13.         j = 1
    
14.    With mxzh
    
15.         For r = 1 To UBound(arr, 1)
    
16.             If arr(r, 11) = Range("l4") And arr(r, 12) = Range("m4") Then
    
17.                 i = i + 1
    
18.                 ReDim Preserve arr1(1 To 17, 1 To i)
    
19.                     For l = 1 To 17
    
20.                         arr1(l, j) = arr(r, l)
    
21.                     Next l
    
22.                     j = j + 1
    
23. 
    
24.             Else
    
25.                If arr(r, 11) = Range("l4") And Range("m4") = 0 Then
    
26.                    i = i + 1
    
27.                    ReDim Preserve arr1(1 To 17, 1 To i)
    
28.                    For l = 1 To 17
    
29.                        arr1(l, j) = arr(r, l)
    
30.                     Next l
    
31.                     j = j + 1
    
32.                 End If
    
33.             End If
    
34.         Next r
    
35.         
    
36.            [b7].Resize(UBound(arr1, 2), 17) = Application.Transpose(arr1)
    
37.        End With
    
38.     End Sub

复制代码

那么的帅

回复 scl5801 的帖子

统计-1(VBA).rar (56.71 KB, 下载次数: 20)

2011-10-28 16:30 上传

点击文件名下载附件

scl5801

感谢楼上的各位热心帮助！！！