返回列表 上一主題 發帖

[發問] 根據多條件篩選清單

回復 1# maiko

剛不久前,我作了一個類似的,修改了一下,也不知是不是應你的要求!
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2. If Target.Address = [k3].Address Then
  3.         Range("B2:G" & Cells(Rows.Count, 2).End(xlUp).Row).AutoFilter
  4.         ActiveWorkbook.Worksheets("工作表1").AutoFilter.Sort.SortFields.Clear
  5.         ActiveWorkbook.Worksheets("工作表1").AutoFilter.Sort.SortFields.Add Key:=Range( _
  6.             "B2:B" & Cells(Rows.Count, 2).End(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
  7.             xlSortNormal
  8.         With ActiveWorkbook.Worksheets("工作表1").AutoFilter.Sort
  9.             .Header = xlYes
  10.             .MatchCase = False
  11.             .Orientation = xlTopToBottom
  12.             .SortMethod = xlPinYin
  13.             .Apply
  14.         End With
  15.         Range("B2:G" & Cells(Rows.Count, 2).End(xlUp).Row).AutoFilter
  16.         
  17.     shop = [k3]
  18.     For Each Rng In Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row)
  19.         If Rng = shop Then
  20.             K = K + 1
  21.             If K = 1 Then
  22.                 Set Rn = Rng.Offset(0, 1)
  23.             Else
  24.                 Set Rn = Union(Rn, Rng.Offset(0, 1))
  25.             End If
  26.         End If
  27.     Next
  28.     aa = Rn.Address
  29.     If aa = "" Then
  30.         Exit Sub
  31.     Else
  32.         With [L3].Validation
  33.             .Delete
  34.             .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=" & aa
  35.             .IgnoreBlank = True
  36.             .InCellDropdown = True
  37.             .InputTitle = ""
  38.             .ErrorTitle = ""
  39.             .InputMessage = ""
  40.             .ErrorMessage = ""
  41.             .IMEMode = xlIMEModeNoControl
  42.             .ShowInput = True
  43.             .ShowError = False
  44.         End With
  45.     End If
  46.     [L3] = "請選擇日期"
  47. End If
  48. If Target.Address = [L3].Address Then
  49.     For Each Rang In Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row)
  50.         If Rang = [k3] And Rang.Offset(0, 1) = [L3] Then
  51.             [K5] = Rang.Offset(0, 2)
  52.             [L5] = Rang.Offset(0, 5)
  53.             End
  54.         End If
  55.     Next
  56. End If
  57. End Sub
複製代碼

TOP

回復 1# maiko

順便提一下,資料驗證清單必須是連續的儲存格,所以我程序中有做排序的動作

TOP

回復 4# maiko


   這是工作表的事件程序,所以你必須貼在工作表1的程序中

TOP

本帖最後由 lpk187 於 2015-4-17 19:51 編輯

回復 4# maiko
在工作表1的標籤上按右鍵選擇檢視程式碼

然後在編輯區貼上代碼就行了

1。貼上後,只要你在"K3"儲存格鍵入你的shop,日期欄的清單就會改變,
2。改變日期清單後,只要你改變日期清單的資料,就會得到你要的答案

TOP

回復 4# maiko


    aaa.rar (21.21 KB)

TOP

回復 8# maiko


    不好意思,誤會你的意思,不過你仍可以修改其中的判斷就可以達到你要的東西了!

TOP

本帖最後由 lpk187 於 2015-4-18 18:27 編輯

回復 11# maiko

要查看工作表事件的逐行"F8"鍵,須先在第一行執行中斷"F9"會比較容易觀察逐行執行時相關的區域變數視窗,
下面是我修改過的程式碼,我有用^^^^^^^標誌是修正原來你要的東西,就像我說的只要修改其中的判斷就可以達到你要的目標,
還有這裡是討論區,不是你要程式的地方,所以希望你可以從程式碼中學到東西!

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = [k5].Address Then
    '''''''''''''''''''''''''''''^^^^
        Range("B2:G" & Cells(Rows.Count, 2).End(xlUp).Row).AutoFilter
        ActiveWorkbook.Worksheets("工作表1").AutoFilter.Sort.SortFields.Clear
        ActiveWorkbook.Worksheets("工作表1").AutoFilter.Sort.SortFields.Add Key:=Range( _
            "B2:B" & Cells(Rows.Count, 2).End(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
            xlSortNormal
        With ActiveWorkbook.Worksheets("工作表1").AutoFilter.Sort
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        Range("B2:G" & Cells(Rows.Count, 2).End(xlUp).Row).AutoFilter
        
    shop = [k3]
    Code = [k5]
'^^^^^^^^^^^^^^
    For Each Rng In Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row)
        If Rng = shop And Rng.Offset(0, 2) = Code Then
        '''''''''''''''''''''''''''''''''''^^^^^^^^^^^^^^^'
            K = K + 1
            If K = 1 Then
                Set Rn = Rng.Offset(0, 1)
            Else
                Set Rn = Union(Rn, Rng.Offset(0, 1))
            End If
        End If
    Next
    aa = Rn.Address
    If aa = "" Then
        Exit Sub
    Else
        With [L3].Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=" & aa
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .IMEMode = xlIMEModeNoControl
            .ShowInput = True
            .ShowError = False
        End With
    End If
    [L3].Select
    '^^^^^^^^^^
    [L3] = "請選擇日期"
   
End If
If Target.Address = [L3].Address Then
    If [L3] = "請選擇日期" Then End
    For Each Rang In Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row)
        If Rang = [k3] And Rang.Offset(0, 1) = [L3] And Rang.Offset(0, 2) = [k5] Then
            [L5] = Rang.Offset(0, 5) '''''''''''''''''''''''''''''''''''''''''^^^^^^^^^^^^^^'
            End
        End If
    Next
End If
End Sub

TOP

回復  lpk187


    總是到了這句:             .Add Type:=xlValidateList, AlertStyle:=xlValidAler ...
maiko 發表於 2015-4-22 05:33



這個討論區隨便找都有你要的程式碼,隨便組一組都可以達到你要的目標,看你要不要用心而已!
還有若是程式不能執行,或是你自已不會除錯,最好上傳你的原檔案上來,自有人幫你修正的!

TOP

        靜思自在 : 甘願做、歡喜受。
返回列表 上一主題