[已解决]debug,求高手帮忙: 从sheet (1)筛选出 #N/A 值的列后, 汇总到数组,copy 到另外一个表

BrianBrian

从sheet (1)筛选出 #N/A 值的列后, 汇总到数组,copy 到另外一个sheet 中 (以便进行下一步处理).
其间出现一个 type mismatch 的debug(如下代码红色段). 试验了很长段时间,未能解决. 恳请高手帮忙指点. 谢谢!

1. Sub 筛选空值并一起复制到新的表格()
   
2. Dim arr, arr1(), y As Long, i As Long, R As Long
   
3. With Sheets("ZOSO")
   
4. arr = .Range("C2:G" & .Range("C1048576").End(xlUp).Row).Value <FONT color=blue>'</FONT><FONT color=navy>赋值sheet("ZOZO")中C2到G列最后一列有值的区域为二维数组(1to"Range("C1048576").End(xlUp).Row", 1to5)
   
5. </FONT>End With
   
6. R = Range("C1048576").End(xlUp).Row <FONT color=navy>'定义r为 sheets("ZOSO")中的有值列的范围
   
7. </FONT>For y = 1 To UBound(arr)
   
8. <FONT style="BACKGROUND-COLOR: yellow">If arr(y, 5) = "#N/A" Then
   
9. </FONT>i = i + 1
   
10. ReDim Preserve arr1(1 To 5, 1 To i) <FONT color=navy>'筛选出数组arr中#N/A值的元素,并归类为新的二维数组 arr1
    
11. </FONT>arr1(1, i) = arr(y, 1)
    
12. arr1(2, i) = arr(y, 2)
    
13. arr1(3, i) = arr(y, 3)
    
14. arr1(4, i) = arr(y, 4)
    
15. arr1(5, i) = arr(y, 5)
    
16. End If
    
17. Next y
    
18. Sheets("IPES data").Activate <FONT color=navy>'把新的数组arr1取得的值复制到sheets("IPES")
    
19. </FONT>Range("A" & R).Resize(UBound(arr1, 2), UBound(arr1)) = Application.Transpose(arr1)
    
20. Range("A" & R).Resize(UBound(arr1, 2), UBound(arr1)).Borders.LineStyle = 1
    
21. Range("A" & R + UBound(arr1, 2)).Select
    
22. End Sub
    

复制代码

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-3-30 12:29

1. Sub 筛选空值并一起复制到新的表格()
   
2.     Dim arr, arr1(), y As Long, i As Long, R As Long
   
3.     With Sheets("ZOSO")
   
4.         arr = .Range("C2:G" & .Range("C1048576").End(xlUp).Row).Value    '赋值sheet("ZOZO")中C2到G列最后一列有值的区域为二维数组(1to"Range("C1048576").End(xlUp).Row", 1to5)
   
5.     End With
   
6.     R = Range("C1048576").End(xlUp).Row    '定义r为 sheets("ZOSO")中的有值列的范围
   
7.     For y = 1 To UBound(arr)
   
8.         If VarType(arr(y, 5)) = vbError Then
   
9.             i = i + 1
   
10.             ReDim Preserve arr1(1 To 5, 1 To i)    '筛选出数组arr中#N/A值的元素,并归类为新的二维数组 arr1
    
11.             arr1(1, i) = arr(y, 1)
    
12.             arr1(2, i) = arr(y, 2)
    
13.             arr1(3, i) = arr(y, 3)
    
14.             arr1(4, i) = arr(y, 4)
    
15.             arr1(5, i) = arr(y, 5)
    
16.         End If
    
17.     Next y
    
18.     Sheets("IPES data").Activate    '把新的数组arr1取得的值复制到sheets("IPES")
    
19.     Range("A" & R).Resize(UBound(arr1, 2), UBound(arr1)) = Application.Transpose(arr1)
    
20.     Range("A" & R).Resize(UBound(arr1, 2), UBound(arr1)).Borders.LineStyle = 1
    
21.     Range("A" & R + UBound(arr1, 2)).Select
    
22. End Sub
    

复制代码

跳转到最佳答案楼层

hwc2ycy

错误值不是显示#NA，你看看对应的数据就知道了。显示的是ERROR 2042

hwc2ycy

你用VARTYPE(ARR(Y,5))来测试
返回值为10则是错误值。这里可以用vberror常量更好。

hwc2ycy

1. Sub 筛选空值并一起复制到新的表格()
   
2.     Dim arr, arr1(), y As Long, i As Long, R As Long
   
3.     With Sheets("ZOSO")
   
4.         arr = .Range("C2:G" & .Range("C1048576").End(xlUp).Row).Value    '赋值sheet("ZOZO")中C2到G列最后一列有值的区域为二维数组(1to"Range("C1048576").End(xlUp).Row", 1to5)
   
5.     End With
   
6.     R = Range("C1048576").End(xlUp).Row    '定义r为 sheets("ZOSO")中的有值列的范围
   
7.     For y = 1 To UBound(arr)
   
8.         If VarType(arr(y, 5)) = vbError Then
   
9.             i = i + 1
   
10.             ReDim Preserve arr1(1 To 5, 1 To i)    '筛选出数组arr中#N/A值的元素,并归类为新的二维数组 arr1
    
11.             arr1(1, i) = arr(y, 1)
    
12.             arr1(2, i) = arr(y, 2)
    
13.             arr1(3, i) = arr(y, 3)
    
14.             arr1(4, i) = arr(y, 4)
    
15.             arr1(5, i) = arr(y, 5)
    
16.         End If
    
17.     Next y
    
18.     Sheets("IPES data").Activate    '把新的数组arr1取得的值复制到sheets("IPES")
    
19.     Range("A" & R).Resize(UBound(arr1, 2), UBound(arr1)) = Application.Transpose(arr1)
    
20.     Range("A" & R).Resize(UBound(arr1, 2), UBound(arr1)).Borders.LineStyle = 1
    
21.     Range("A" & R + UBound(arr1, 2)).Select
    
22. End Sub
    

复制代码

无聊的疯子

修改一下表格,直接使用高级筛选



代码如下

1. 
   
2. Sub cc()
   
3. Dim Hx As Long
   
4.   With Sheets("ZOSO")
   
5.     Hx = .Range("A65536").End(xlUp).Row
   
6.     .Range("A1:I" & Hx).AdvancedFilter 2, Range("A1:E2"), Range("A4:E4")
   
7.   End With
   
8. End Sub
   

复制代码

BrianBrian

因每天有很多新的item 条目产生, copy 后的#N/A 部分需要累积叠加保留,  谢谢2楼,4楼老师指点, 解决了我一个大的困惑(不然简直要把头发抓下了).  也谢谢5楼讲师.