[已解决]看了篩選還是不懂，在此求助

idnoidno

小弟希望使用VBA的ARRAY方式，將附件中的工作表1可以篩選出出一月(對應B欄的數值)，可以依序寫到工作表2中，可以請教要如何解決，謝謝

最佳答案

月排行榜 / 总排行榜

france723

2017-5-21 22:43

idnoidno 发表于 2017-5-21 21:10
得到的結果應該不是都是1
不知道哪邊該做調整
可以請問一下

忘记转置了，，SORRY

1. Sub aaa()
   
2. Dim y, arr, brr, crr, n, m
   
3. ReDim brr(1 To 1)
   
4. ReDim crr(1 To 1)
   
5. y = Sheets("工作表1").Range("a65536").End(3).Row  '
   
6. arr = Sheets("工作表1").Range("a1:b" & y)
   
7. For i = 1 To UBound(arr)
   
8.     If arr(i, 1) = "january" Then
   
9.         n = n + 1
   
10.         ReDim Preserve brr(1 To n)
    
11.         ReDim Preserve crr(1 To n)
    
12.         brr(n) = arr(i, 1)
    
13.         crr(n) = arr(i, 2)
    
14.     End If
    
15. Next i
    
16. Sheets("工作表2").Range("a1").Resize(UBound(brr), 1) = Application.Transpose(brr)
    
17. Sheets("工作表2").Range("b1").Resize(UBound(crr), 1) = Application.Transpose(crr)
    
18. End Sub

复制代码

跳转到最佳答案楼层

砂海

筛选 是什么意思? 去除重复 ?

自己 手工模拟个结果.

idnoidno

符合條件的意思，很抱歉，我沒有說明清楚

france723

符合都是一月的吗？ 代码如下

1. Sub aaa()
   
2. Dim y, arr, brr, crr, n, m
   
3. ReDim brr(1 To 1)
   
4. ReDim crr(1 To 1)
   
5. y = Sheets("工作表1").Range("a65536").End(3).Row  '
   
6. arr = Sheets("工作表1").Range("a1:b" & y)
   
7. For i = 1 To UBound(arr)
   
8.     If arr(i, 1) = "january" Then
   
9.         n = n + 1
   
10.         ReDim Preserve brr(1 To n)
    
11.         ReDim Preserve crr(1 To n)
    
12.         brr(n) = arr(i, 1)
    
13.         crr(n) = arr(i, 2)
    
14.     End If
    
15. Next i
    
16. Sheets("工作表2").Range("a1").Resize(UBound(brr), 1) = brr
    
17. Sheets("工作表2").Range("b1").Resize(UBound(crr), 1) = crr
    
18. End Sub

复制代码

idnoidno

表格是

january	1
february	2
march	3
april	4
may	5
june	6
july	7
august	8
september	9
october	10
november	11
december	12
january	13
february	14
march	15
april	16
may	17
june	18
july	19
august	20
september	21
october	22
november	23
december	24
january	25
february	26
march	27
april	28
may	29

結果

january	1
january	1
january	1

france723

idnoidno 发表于 2017-5-21 20:15
表格是

?我的代码就这结果，有问题吗？？？？

idnoidno

得到的結果應該不是都是1
不知道哪邊該做調整
可以請問一下
如果是有A、B、C、D更多的COLUMN時
你的數組(ARRAY)該要怎樣調整呢

france723

idnoidno 发表于 2017-5-21 21:10
得到的結果應該不是都是1
不知道哪邊該做調整
可以請問一下

忘记转置了，，SORRY

1. Sub aaa()
   
2. Dim y, arr, brr, crr, n, m
   
3. ReDim brr(1 To 1)
   
4. ReDim crr(1 To 1)
   
5. y = Sheets("工作表1").Range("a65536").End(3).Row  '
   
6. arr = Sheets("工作表1").Range("a1:b" & y)
   
7. For i = 1 To UBound(arr)
   
8.     If arr(i, 1) = "january" Then
   
9.         n = n + 1
   
10.         ReDim Preserve brr(1 To n)
    
11.         ReDim Preserve crr(1 To n)
    
12.         brr(n) = arr(i, 1)
    
13.         crr(n) = arr(i, 2)
    
14.     End If
    
15. Next i
    
16. Sheets("工作表2").Range("a1").Resize(UBound(brr), 1) = Application.Transpose(brr)
    
17. Sheets("工作表2").Range("b1").Resize(UBound(crr), 1) = Application.Transpose(crr)
    
18. End Sub

复制代码

france723

idnoidno 发表于 2017-5-21 21:10
得到的結果應該不是都是1
不知道哪邊該做調整
可以請問一下

如果很多列，你可以采用筛选整行复制的方法。

1. Sub bbb()
   
2. Dim y, arr, n
   
3. n = 1
   
4. y = Sheets("工作表1").Range("a65536").End(3).Row
   
5. arr = Sheets("工作表1").Range("a1:b" & y)
   
6. For i = 1 To UBound(arr)
   
7.     If arr(i, 1) = "january" Then
   
8.             Sheets("工作表1").Rows(i).Copy
   
9.             Sheets("工作表2").Select
   
10.             Rows(n).Select
    
11.             Sheets("工作表2").Paste
    
12.             n = n + 1
    
13.     End If
    
14. Next i
    
15. End Sub

复制代码

idnoidno

可以再進一步請問，若是附件這樣，您的CODE要如何調整呢