[發問] 請問VBA可以篩選後，對其結果再進行進階篩選嗎?

本帖最後由 iceandy6150 於 2021-11-29 23:25 編輯

大家好
想請問VBA有沒有辦法做到
篩選後，出來的結果，在做進階篩選?

以下例子
我想做到先篩選出2021/11/23的項目
看看總共幾個符合 (紅色)

然後針對商品去進行"進階篩選" (綠色) 不重複
最後是把各種商品的總數量加起來 (藍色)

功能需求：
我要做一個查詢功能，使用者透過Inputbox，給我年月日
我要從很多很多資料中
先篩選出當天日期的資料，然後分析當天總共有多少種類的產品，加總各產品的數量
(有點類似樞紐分析)

再請各位指導，謝謝

測試篩選並複製特定範圍.rar (29.08 KB)
(按鈕三)

Private Sub CommandButton3_Click()
Dim i
Dim a
Dim Sg As Range
i = Sheets("工作表2").Cells(1, 9).Value
a = Sheets("工作表2").Columns(2).End(xlDown).Row
Dim Rng As Range '篩選結果範圍
With Sheets("工作表2") '在工作表2中
Set Rng = .UsedRange.Range("A1:F" & a) '所有資料範圍中的A1~F底
Rng.AutoFilter Field:=1, Criteria1:="2021/11/23"
Set fa = [d2:d65536].SpecialCells(xlCellTypeVisible)(1)
Set fb = [D65536].End(xlUp)
If fa = "" Then
MsgBox "查無資料"
Sheets("工作表2").Range("A:E").AutoFilter
Exit Sub
End If
Set Sg = .Range("A" & fa.Row & ":F" & fb.Row)
'●想針對剛剛篩選出來的範圍進行進階篩選不重複放到K1
Sg.AdvancedFilter xlFilterCopy, .Range("D:D"), Sheets("工作表2").Range("K1"), True
End With
End Sub

複製代碼

最後再用 Application.SumIfs 去加總各種類的商品共有多少

樓主熱帖

哈囉~大家好呀

samwang

高中生 Rank: 3 Rank: 3

帖子: 850
主題: 7
精華: 0
積分: 893
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2022-5-26

2^#

發表於 2021-11-30 08:06 | 只看該作者

回復 1# iceandy6150

請測試看看，謝謝
Sub test()
Dim Arr, Brr(), xD, T1, T4$, ND As Date, i&, j%,n%
Set xD = CreateObject("Scripting.Dictionary")
ND = InputBox("請輸入日期：", "日期", "2021/1/1")
Arr = Range([e1], [a65536].End(3))
ReDim Brr(1 To UBound(Arr), 1 To 5)
For i = 2 To UBound(Arr)
T1 = Arr(i, 1): T4 = Arr(i, 4)
If ND = T1 And xD(T4) = "" Then
      n = n + 1: xD(T4) = n
      For j = 1 To 5: Brr(n, j) = Arr(i, j): Next
      xD(ND & "/1") = xD(ND & "/1") + Arr(i, 5)
End If
Next
[u1].CurrentRegion = ""
If n > 0 Then
Range("a1:f1").Copy [u1]
Range("u2").Resize(n, 5) = Brr
Range("x" & n + 2) = n
Range("y" & n + 2) = xD(ND & "/1")
Else
MsgBox "無資料"
End If
End Sub

TOP

iceandy6150

中學生 Rank: 2

帖子: 129
主題: 25
精華: 0
積分: 159
點名: 0
作業系統: win7
軟體版本: office2010
閱讀權限: 20
性別: 男
註冊時間: 2011-12-24
最後登錄: 2022-2-12

3^#

發表於 2021-11-30 15:37 | 只看該作者

回復 2# samwang

samwang大大，可以使用
感謝你

如果你方便的話
可以下一些註解嗎?
對於字典還有陣列的用法
我比較想不透
感謝你喔

哈囉~大家好呀

TOP

samwang

高中生 Rank: 3 Rank: 3

帖子: 850
主題: 7
精華: 0
積分: 893
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2022-5-26

4^#

發表於 2021-11-30 15:59 | 只看該作者

回復 samwang

samwang大大，可以使用
感謝你

如果你方便的話
可以下一些註解嗎?
對於字典還 ...
iceandy6150 發表於 2021-11-30 15:37

Sub test()
Dim Arr, Brr(), xD, T1, T4$, ND As Date, i&, j%, n%
Set xD = CreateObject("Scripting.Dictionary")
ND = InputBox("請輸入日期：", "日期", "2021/1/1") '需求日期
Arr = Range([e1], [a65536].End(3))  '資料裝入Arr數組
ReDim Brr(1 To UBound(Arr), 1 To 5) '符合需求的Brr數組
For i = 2 To UBound(Arr)
T1 = Arr(i, 1): T4 = Arr(i, 4)
If ND = T1 And xD(T4) = "" Then '有符合日期且商品名稱不重複
      n = n + 1: xD(T4) = n    '統計商品不重複數量
      For j = 1 To 5: Brr(n, j) = Arr(i, j): Next  '符合資料裝到Brr數組
      xD(ND & "/1") = xD(ND & "/1") + Arr(i, 5) '統計數量裝字典
End If
Next
[u1].CurrentRegion = "" '清除
If n > 0 Then
Range("a1:f1").Copy [u1]          'copy抬頭
Range("u2").Resize(n, 5) = Brr    '匯出Brr
Range("x" & n + 2) = n             '匯出統計商品不重複數量
Range("y" & n + 2) = xD(ND & "/1")  '匯出統計數量
Else
MsgBox "無資料"
End If
End Sub

TOP

iceandy6150

中學生 Rank: 2

帖子: 129
主題: 25
精華: 0
積分: 159
點名: 0
作業系統: win7
軟體版本: office2010
閱讀權限: 20
性別: 男
註冊時間: 2011-12-24
最後登錄: 2022-2-12

5^#

發表於 2021-12-3 00:16 | 只看該作者

回復 4# samwang

非常感謝samwang大大教學
謝謝你

哈囉~大家好呀

TOP