[已解决]麻烦各位老师知道如何筛选生成新表，请看附件里说明。

fywb2000

麻烦各位老师知道如何筛选生成新表，请看附件里说明 工作簿3.rar (15.51 KB, 下载次数: 8)

2014-3-6 20:34 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

独奏

2014-3-6 21:09

请先保存好副本，只有数据格式要自己重新设置了

1. Sub test()
   
2. Dim br, arr, brr(), r, c, x, y
   
3. br = Range("a1:h" & [a65536].End(xlUp).Row)
   
4. arr = Range("i1:p" & [i65536].End(xlUp).Row)
   
5. For c = LBound(arr, 2) To UBound(arr, 2)
   
6.     If arr(1, c) >= 0.6 Then
   
7.         y = y + 1
   
8.         ReDim Preserve brr(1 To 23, 1 To y)
   
9.         For r = LBound(arr) To UBound(arr)
   
10.             For x = 1 To 23
    
11.                 brr(x, y) = arr(x, c)
    
12.             Next
    
13.         Next
    
14.     End If
    
15. Next
    
16. Sheets("百分比筛选").Range("l1").Resize(23, 8) = br
    
17. Sheets("百分比筛选").Range("t1").Resize(23, y) = brr
    
18. y = 0
    
19. Erase brr
    
20. For c = LBound(arr, 2) To UBound(arr, 2)
    
21.     If arr(2, c) <= 3 Then
    
22.         y = y + 1
    
23.         ReDim Preserve brr(1 To 23, 1 To y)
    
24.         For r = LBound(arr) To UBound(arr)
    
25.             For x = 1 To 23
    
26.                 brr(x, y) = arr(x, c)
    
27.             Next
    
28.         Next
    
29.     End If
    
30. Next
    
31. Sheets("最大未报筛选").Range("l1").Resize(23, 8) = br
    
32. Sheets("最大未报筛选").Range("t1").Resize(23, y) = brr
    
33. erase brr
    
34. set br=nothing
    
35. set arr=nothing
    
36. End Sub

复制代码

跳转到最佳答案楼层

独奏

请先保存好副本，只有数据格式要自己重新设置了

1. Sub test()
   
2. Dim br, arr, brr(), r, c, x, y
   
3. br = Range("a1:h" & [a65536].End(xlUp).Row)
   
4. arr = Range("i1:p" & [i65536].End(xlUp).Row)
   
5. For c = LBound(arr, 2) To UBound(arr, 2)
   
6.     If arr(1, c) >= 0.6 Then
   
7.         y = y + 1
   
8.         ReDim Preserve brr(1 To 23, 1 To y)
   
9.         For r = LBound(arr) To UBound(arr)
   
10.             For x = 1 To 23
    
11.                 brr(x, y) = arr(x, c)
    
12.             Next
    
13.         Next
    
14.     End If
    
15. Next
    
16. Sheets("百分比筛选").Range("l1").Resize(23, 8) = br
    
17. Sheets("百分比筛选").Range("t1").Resize(23, y) = brr
    
18. y = 0
    
19. Erase brr
    
20. For c = LBound(arr, 2) To UBound(arr, 2)
    
21.     If arr(2, c) <= 3 Then
    
22.         y = y + 1
    
23.         ReDim Preserve brr(1 To 23, 1 To y)
    
24.         For r = LBound(arr) To UBound(arr)
    
25.             For x = 1 To 23
    
26.                 brr(x, y) = arr(x, c)
    
27.             Next
    
28.         Next
    
29.     End If
    
30. Next
    
31. Sheets("最大未报筛选").Range("l1").Resize(23, 8) = br
    
32. Sheets("最大未报筛选").Range("t1").Resize(23, y) = brr
    
33. erase brr
    
34. set br=nothing
    
35. set arr=nothing
    
36. End Sub

复制代码

fywb2000

独奏 发表于 2014-3-6 21:09
请先保存好副本，只有数据格式要自己重新设置了

感谢老师的帮助，谢谢！~