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

iceandy6150

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

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

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

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

再請各位指導，謝謝

下載 (130.31 KB)

2021-11-29 23:18

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

下載次數: 12

2021-11-29 23:18

(按鈕三)

1. Private Sub CommandButton3_Click()
   
2. 
   
3. Dim i
   
4. Dim a
   
5. Dim Sg As Range
   
6. 
   
7. 
   
8. i = Sheets("工作表2").Cells(1, 9).Value
   
9. a = Sheets("工作表2").Columns(2).End(xlDown).Row
   
10. 
    
11. Dim Rng As Range        '篩選結果範圍
    
12. 
    
13.     With Sheets("工作表2")       '在工作表2中
    
14.         Set Rng = .UsedRange.Range("A1:F" & a)  '所有資料範圍中的A1~F底
    
15.         Rng.AutoFilter Field:=1, Criteria1:="2021/11/23"
    
16.         
    
17.         Set fa = [d2:d65536].SpecialCells(xlCellTypeVisible)(1)
    
18.         Set fb = [D65536].End(xlUp)
    
19.         
    
20.         If fa = "" Then
    
21.             MsgBox "查無資料"
    
22.             Sheets("工作表2").Range("A:E").AutoFilter
    
23.             Exit Sub
    
24.         End If
    
25.         
    
26.         Set Sg = .Range("A" & fa.Row & ":F" & fb.Row)
    
27.         '●想針對剛剛篩選出來的範圍  進行  進階篩選不重複  放到K1
    
28.         Sg.AdvancedFilter xlFilterCopy, .Range("D:D"), Sheets("工作表2").Range("K1"), True
    
29.    End With
    
30. End Sub

複製代碼

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

samwang

回復 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

iceandy6150

回復 2# samwang


samwang大大，可以使用
感謝你

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

samwang

回復  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

iceandy6150

回復 4# samwang


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

Andy2483

謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,學習方案如下,請各位前輩指教

執行前:

下載 (106.79 KB)

2023-6-15 10:58

輸入 2021/11/21 後按鈕執行結果:

下載 (112.68 KB)

2023-6-15 10:58

Option Explicit
Sub TEST()
Dim Brr, Z, V1&, V2&, V3, i&, j%, R&, N&, T$
'↑宣告變數
Intersect(ActiveSheet.UsedRange, [U2:Z65536]).ClearContents
If IsDate([S2]) = False Then MsgBox "[S2]需輸入日期": Exit Sub
'↑如果[S2]儲存格值不是日期? True就跳出提示,結束程式執行
Set Z = CreateObject("Scripting.Dictionary")
'↑令Z變數是 字典
Brr = Range([F1], [A65536].End(xlUp))
'↑令Brr變數是 二維陣列,以A~F欄儲存格值帶入陣列中
For i = 2 To UBound(Brr)
'↑設順迴圈
   T = Brr(i, 1) & "|" & Brr(i, 3) & "|" & Brr(i, 4)
   '↑令T變數是 第1.3.4欄迴圈陣列值的組合字串,中間以"|"間隔
   If InStr(T, [S2] & "|") = 0 Then GoTo i01
   '↑如果T組合字串不符合條件? True就跳到標示i01位置繼續執行
   If Z(Brr(i, 4)) = "" Then V1 = V1 + 1: Z(Brr(i, 4)) = 1
   '↑如果商品名稱不在Z字典裡? True就令V1變數累加1後,
   '將 商品名稱key對應item改為1
   V2 = V2 + Brr(i, 5): V3 = V3 + Brr(i, 6)
   '↑令V2變數累加 數量,'↑令V3變數累加 消費金額
   N = Z(T)
   '↑令N變數是 以T變數查Z字典回傳item值
   If N = 0 Then
   '↑如果N變數是 0
      R = R + 1: For j = 1 To 6: Brr(R, j) = Brr(i, j): Next
      '↑令R變數累加1,設順迴圈將迴圈列陣列值謄到指定的 R變數列
      Z(T) = R: GoTo i01
     '↑令T變數key對應item改為R變數,令跳到標示i01位置繼續執行
   End If
   Brr(N, 5) = Brr(N, 5) + Brr(i, 5): Brr(N, 6) = Brr(N, 6) + Brr(i, 6)
   '↑令第二次以上出現的T變數,其數量與消費金額累加
i01: Next
If R > 0 Then R = R + 1 Else: MsgBox "無符合條件資料": Exit Sub
For j = 1 To 3: Brr(R, j) = "": Next
Brr(R, 4) = V1: Brr(R, 5) = V2: Brr(R, 6) = V3
'↑令加總值放在陣列裡
[U2].Resize(R, 6) = Brr
'↑令從[U2]擴展範圍儲存格值以Brr陣列值寫入,超過範圍的陣列值忽略
Set Z = Nothing: Erase Brr
'↑令釋放變數
End Sub