麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 請問VBA可以篩選後，對其結果再進行進階篩選嗎? [打印本頁]

作者: iceandy6150 時間: 2021-11-29 23:20 標題: 請問VBA可以篩選後，對其結果再進行進階篩選嗎?

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

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

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

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

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

再請各位指導，謝謝
[attach]34451[/attach]

[attach]34452[/attach]
(按鈕三)

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 時間: 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

作者: iceandy6150 時間: 2021-11-30 15:37

回復 2# samwang

samwang大大，可以使用
感謝你

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

作者: samwang 時間: 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

作者: iceandy6150 時間: 2021-12-3 00:16

回復 4# samwang

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

作者: Andy2483 時間: 2023-6-15 11:02

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

執行前:
[attach]36588[/attach]

輸入 2021/11/21 後按鈕執行結果:
[attach]36589[/attach]

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

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)