返回列表 上一主題 發帖

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

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

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

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

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

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

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

再請各位指導,謝謝
篩選後再進階篩選.jpg
2021-11-29 23:18


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

  2. Dim i
  3. Dim a
  4. Dim Sg As Range


  5. i = Sheets("工作表2").Cells(1, 9).Value
  6. a = Sheets("工作表2").Columns(2).End(xlDown).Row

  7. Dim Rng As Range        '篩選結果範圍

  8.     With Sheets("工作表2")       '在工作表2中
  9.         Set Rng = .UsedRange.Range("A1:F" & a)  '所有資料範圍中的A1~F底
  10.         Rng.AutoFilter Field:=1, Criteria1:="2021/11/23"
  11.         
  12.         Set fa = [d2:d65536].SpecialCells(xlCellTypeVisible)(1)
  13.         Set fb = [D65536].End(xlUp)
  14.         
  15.         If fa = "" Then
  16.             MsgBox "查無資料"
  17.             Sheets("工作表2").Range("A:E").AutoFilter
  18.             Exit Sub
  19.         End If
  20.         
  21.         Set Sg = .Range("A" & fa.Row & ":F" & fb.Row)
  22.         '●想針對剛剛篩選出來的範圍  進行  進階篩選不重複  放到K1
  23.         Sg.AdvancedFilter xlFilterCopy, .Range("D:D"), Sheets("工作表2").Range("K1"), True
  24.    End With
  25. End Sub
複製代碼
最後再用 Application.SumIfs 去加總各種類的商品共有多少
哈囉~大家好呀

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

回復 2# samwang


samwang大大,可以使用
感謝你

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

TOP

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

回復 4# samwang


非常感謝samwang大大教學
謝謝你
哈囉~大家好呀

TOP

        靜思自在 : 道德是提昇自我的明燈,不該是呵斥別人的鞭子。
返回列表 上一主題