[已解决]EXCELVBA用数组提取符合条件的行数据组成新数组

changrs

新手学数组希望高手指导.问题为:
1.如下代码不知道错在哪,请指正?
2.能否改善代码提高效率?
谢谢!
Sub aa()
Dim arr, arr1
Dim i%, j%,s%
arr = Range("a1:e" & [A65536].End(3).Row) '第一行为标题行'
ReDim arr1(1 To UBound(arr), 1 To 5)  '列宽度固定'
For i = 2 To UBound(arr)  '数据区域从第二行开始'
s = 0
For j = 1 To 5
If arr(i, 2) = "X" Then
s = s + 1
arr1(s, j) = arr(i, j)   '错误提示:下标越界,这时的S=0
End If
Next
Next
[g1].Resize(s, 5) = arr1  '错误提示:应用程序定义错误或对象定义错误,这时S=0'
End Sub

最佳答案

月排行榜 / 总排行榜

hello_cgj

2015-6-12 11:40

你循环循环错了吧
这样试试

1. Sub aa()
   
2. Dim arr, arr1
   
3. Dim i%, j%, s%
   
4. 
   
5. arr = Range("a1:e" & [A65536].End(3).Row) '第一行为标题行'
   
6. ReDim arr1(1 To UBound(arr), 1 To 5)
   
7. s = 0
   
8. For i = 2 To UBound(arr)  '数据区域从第二行开始'
   
9. If arr(i, 2) = "X" Then
   
10. s = s + 1
    
11. For j = 1 To 5
    
12. arr1(s, j) = arr(i, j)   '错误提示:下标越界,这时的S=0
    
13. Next
    
14. End If
    
15. Next
    
16. [g1].Resize(s, 5) = arr1
    
17. End Sub
    

复制代码

跳转到最佳答案楼层

蓝桥玄霜

建议上传表格附件来说明问题。

E-H-P

你自己都指出错误了，你还不知道错在哪里？

hello_cgj

Sub aa()
Dim arr, arr1
Dim i%, j%,s%
arr = Range("a1:e" & [A65536].End(3).Row) '第一行为标题行'
ReDim arr1(1 To UBound(arr), 1 To 5)  '列宽度固定'
s = 0
For i = 2 To UBound(arr)  '数据区域从第二行开始'
For j = 1 To 5
If arr(i, 2) = "X" Then
s = s + 1
arr1(s, j) = arr(i, j)   '错误提示:下标越界,这时的S=0
End If
Next
Next
[g1].Resize(s, 5) = arr1  '错误提示:应用程序定义错误或对象定义错误,这时S=0'
End Sub
S=0放到循环外面试试。看看是不是因为这个出错。

changrs

hello_cgj 发表于 2015-6-12 11:19
Sub aa()
Dim arr, arr1
Dim i%, j%,s%

这个早已试过,不行.

changrs

这是问题的表附件:

E-H-P

if s=0 then exit sub
[g1].Resize(s, 5) = arr1  '错误提示:应用程序定义错误或对象定义错误,这时S=0'
End Sub

E-H-P

E-H-P 发表于 2015-6-12 11:34
if s=0 then exit sub
[g1].Resize(s, 5) = arr1  '错误提示:应用程序定义错误或对象定义错误,这时S=0'
E ...

估计s=0就是没有合适的数据，没有数据就白忙一场 ，直接退出就可以了。

hello_cgj

你循环循环错了吧
这样试试

1. Sub aa()
   
2. Dim arr, arr1
   
3. Dim i%, j%, s%
   
4. 
   
5. arr = Range("a1:e" & [A65536].End(3).Row) '第一行为标题行'
   
6. ReDim arr1(1 To UBound(arr), 1 To 5)
   
7. s = 0
   
8. For i = 2 To UBound(arr)  '数据区域从第二行开始'
   
9. If arr(i, 2) = "X" Then
   
10. s = s + 1
    
11. For j = 1 To 5
    
12. arr1(s, j) = arr(i, j)   '错误提示:下标越界,这时的S=0
    
13. Next
    
14. End If
    
15. Next
    
16. [g1].Resize(s, 5) = arr1
    
17. End Sub
    

复制代码

scl5801

changrs 发表于 2015-6-12 11:33
这是问题的表附件:

Sub aa()
Dim arr, arr1
Dim i%, j%, s%
arr = Range("a1:e" & [A65536].End(3).Row) '第一行为标题行'
ReDim arr1(1 To UBound(arr), 1 To 5)
s = 1
For i = 2 To UBound(arr)  '数据区域从第二行开始'
   If arr(i, 2) = "X" Then
      For j = 1 To 5
        arr1(s, j) = arr(i, j)   '错误提示:下标越界,这时的S=0
      Next
      s = s + 1
   End If
Next
[g1].Resize(s, 5) = arr1
End Sub