返回列表 上一主題 發帖

[發問] 下拉式清單裡選擇"篩選不重複的資料"

回復 12# lifedidi
1有辦法照順序
  1. Private Sub UserForm_Initialize()  '表單初始化的程序
  2.     Dim D As Object
  3.     Set D = CreateObject("Scripting.Dictionary")    '字典物件
  4.     With Sheet1
  5.         For Each a In .Range(.[D7], .[D7].End(xlDown))
  6.             D(a.Value) = ""
  7.         Next
  8.     End With
  9.     ComboBox1.List = D.keys       '專案選項內容
  10. End Sub
  11. Private Sub ComboBox1_Change()      '專案選項內容: 有改變
  12.     If ComboBox1.ListIndex > -1 Then
  13.         ComboBox2資料
  14.     Else                            '改變的內容不在List中
  15.         ComboBox2.Clear
  16.     End If
  17. End Sub
  18. Private Sub ComboBox2資料()
  19.     Dim D As Object
  20.     Set D = CreateObject("Scripting.Dictionary")
  21.     With Sheet1
  22.         For Each a In .Range(.[D7], .[D7].End(xlDown))
  23.             If a.Value = ComboBox1 Then D(a.Offset(, 3).Value) = ""    '
  24.         Next
  25.         With .Columns(.Columns.Count).EntireColumn           'Sheet1的最後一欄
  26.             .Clear
  27.             .Cells(1).Resize(D.Count, 1) = Application.WorksheetFunction.Transpose(D.keys)
  28.             '*** 排序
  29.             .Cells(1).Resize(D.Count, 1).Sort Key1:=.Cells(1), Order1:=xlAscending, Header:= _
  30.                     xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
  31.                     SortMethod:=xlStroke, DataOption1:=xlSortNormal
  32.             '*******
  33.             ComboBox2.List = .Cells(1).Resize(D.Count, 1).Value  '工種選項內容
  34.             ComboBox2.Value = ComboBox2.List(0)                  '工種選項的值
  35.             .Clear
  36.         End With
  37.     End With
  38. End Sub
複製代碼
2電腦不吃力
  1. Public Sub 清除()
  2.     With Sheet2
  3.         '.Cells(7, 3).Resize(999 - 7 + 1, 25 - 3 + 1) = ""
  4.         .Cells(7, 3).Resize(993, 23) = ""
  5.         'For i = 7 To 999
  6.         '    For j = 3 To 25
  7.         '   Cells(i, j) = ""
  8.         '   Next
  9.         ' Next
  10.     End With
  11. End Sub
複製代碼

TOP

回復 14# lifedidi
附檔中UserForm1的程式碼
  1. Private Sub UserForm_Initialize()                   '表單初始化的程序
  2.     Dim D As Object
  3.     Set D = CreateObject("Scripting.Dictionary")    '字典物件
  4.     Sheet2.Range("b1").CurrentRegion.Offset(1) = "" '先清除舊資料
  5.     With Sheet1
  6.         .AutoFilterMode = False                     '取消自動篩選模式
  7.         For Each A In .Range(.[A2], .[A2].End(xlDown))
  8.             D(A.Value) = ""
  9.         Next
  10.         ComboBox1.List = D.KEYS                     '專案選項內容
  11.     End With
  12. End Sub
  13. Private Sub ComboBox1_Change()                      '專案選項內容: 有改變
  14.      With Sheet1
  15.         .AutoFilterMode = False
  16.         If ComboBox1.ListIndex > -1 Then
  17.             ComboBox2資料
  18.             .Range("a1").AutoFilter 1, ComboBox1    '自動篩選模式:第1欄的篩選準則為 ComboBox1的值
  19.         Else                                        '改變的內容不在List中
  20.             .Range("a1").AutoFilter 1, "<>"         '自動篩選模式:第1欄的篩選準則為不是空白欄
  21.             ComboBox2.Clear
  22.         End If
  23.         資料複製
  24.     End With
  25. End Sub
  26. Private Sub ComboBox2_Change()                      '專案選項內容: 有改變
  27.     If ComboBox2.ListIndex > -1 Then
  28.         Sheet1.Range("a1").AutoFilter 2, ComboBox2  '自動篩選模式:第2欄的篩選準則為 ComboBox2的值
  29.     Else
  30.         Sheet1.Range("a1").AutoFilter 2, "<>"       '自動篩選模式:第2欄的篩選準則為不是空白欄
  31.     End If
  32.     資料複製
  33. End Sub
  34. Private Sub ComboBox2資料()
  35.     Dim D As Object, A
  36.     Set D = CreateObject("Scripting.Dictionary")
  37.     With Sheet1
  38.         For Each A In .Range(.[A2], .[A2].End(xlDown))
  39.             If A.Value = ComboBox1 Then D(A.Offset(, 1).Value) = ""
  40.         Next
  41.         If D.Count > 1 Then
  42.             With .Columns(.Columns.Count).EntireColumn           'Sheet1的最後一欄
  43.                 .Clear
  44.                 .Cells(1).Resize(D.Count, 1).Value = Application.WorksheetFunction.Transpose(D.KEYS)
  45.                 '*** 排序
  46.                 .Cells(1).Resize(D.Count, 1).Sort Key1:=.Cells(1), Order1:=xlAscending, Header:= _
  47.                     xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
  48.                     SortMethod:=xlStroke, DataOption1:=xlSortNormal
  49.                 '*******
  50.                 ComboBox2.List = .Cells(1).Resize(D.Count, 1).Value  '工種選項內容
  51.                 .Clear
  52.             End With
  53.         Else
  54.             A = D.KEYS
  55.             ComboBox2.AddItem A(0)
  56.         End If
  57.             ComboBox2.Value = ComboBox2.List(0)                  '工種選項的值
  58.     End With
  59. End Sub
  60. Private Sub 資料複製()
  61.     Dim Rng As Range
  62.     Sheet2.Range("b1").CurrentRegion = ""             '先清除舊資料
  63.     Sheet1.Range("a1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy Sheet2.Range("b1")
  64.     '複製:'自動篩選出的資料
  65. End Sub
  66. Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
  67.     Sheet1.AutoFilterMode = False      '表單關閉前取消自動篩選模式
  68. End Sub
複製代碼

TOP

本帖最後由 GBKEE 於 2013-3-12 08:49 編輯

回復 16# lifedidi
  1. Dim 資料表 As Worksheet  '***設定資料工作表 供表單中的程序共同使用 ***
  2. Dim 查詢表 As Worksheet  '***設定資料工作表 供表單中的程序共同使用 ***
  3. Private Sub UserForm_Initialize()  '表單初始化的程序
  4.     Dim D As Object
  5.     Set D = CreateObject("Scripting.Dictionary")    '字典物件
  6.     Set 資料表 = Sheet1      ' 資料工作表 或 查詢工作表 的工作表 如有變動時
  7.     Set 查詢表 = Sheet2      ' 在此修改:不必去所有程式碼中一一修改工作表名稱
  8.     With 資料表
  9.         .AutoFilterMode = False
  10.         For Each a In .Range(.[A2], .[A2].End(xlDown))
  11.             D(a.Value) = ""
  12.         Next
  13.     End With
  14.     ComboBox1.List = D.keys       '專案選項內容
  15. End Sub
  16. Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
  17.         '表單關閉的程序
  18.         資料表.AutoFilterMode = False                             '取消自動篩選
  19.         查詢表.UsedRange.Offset(1) = ""
  20. End Sub
  21. Private Sub CommandButton1_Click()
  22.     '*** UserForm2 的ListBox1 改成 TextBox 控制項             *****
  23.     With UserForm2
  24.         .TextBox1 = Application.Text(Application.Sum(查詢表.[D:D]), "[hh]:mm")
  25.         .Show 0
  26.     End With
  27. End Sub
  28. Private Sub ComboBox1_Change()      '專案選項內容: 有改變
  29.     If ComboBox1.ListIndex > -1 Then
  30.         ComboBox2資料
  31.     Else                            '改變的內容不在List中
  32.         ComboBox2.Clear
  33.     End If
  34.     Show_資料
  35. End Sub
  36. Private Sub ComboBox2_Change()      '專案選項內容: 有改變
  37.     Show_資料
  38. End Sub
  39. Private Sub ComboBox2資料()
  40.     Dim D As Object
  41.     Set D = CreateObject("Scripting.Dictionary")
  42.     With 資料表
  43.         .AutoFilterMode = False
  44.         For Each a In .Range(.[A2], .[A2].End(xlDown))
  45.             If a.Value = ComboBox1 Then D(a.Offset(, 1).Value) = ""    '
  46.         Next
  47.         With .Columns(.Columns.Count).EntireColumn           'Sheet1的最後一欄
  48.             .Clear
  49.             .Cells(1).Resize(D.Count, 1) = Application.WorksheetFunction.Transpose(D.keys)
  50.             '*** 排序
  51.             .Cells(1).Resize(D.Count, 1).Sort Key1:=.Cells(1), Order1:=xlAscending, Header:= _
  52.                     xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
  53.                     SortMethod:=xlStroke, DataOption1:=xlSortNormal
  54.             '*******
  55.             ComboBox2.List = .Cells(1).Resize(D.Count, 1).Value  '工種選項內容
  56.             ComboBox2.Value = ComboBox2.List(0)                  '工種選項的值
  57.             .Clear
  58.         End With
  59.     End With
  60. End Sub
  61. Private Sub Show_資料()
  62.     UserForm2.TextBox1 = ""
  63.     With 資料表
  64.         .AutoFilterMode = False                             '取消自動篩選
  65.         If ComboBox1.ListIndex > -1 Then
  66.             .Range("A1").AutoFilter 1, ComboBox1            '自動篩選: 第一欄(A欄)的準則 為 ComboBox1
  67.             If ComboBox2.ListIndex > -1 Then
  68.                 .Range("A1").AutoFilter 2, ComboBox2        '自動篩選: 第一欄(A欄)的準則 為 ComboBox12
  69.             End If
  70.         End If
  71.         .UsedRange.Range("A:C").Copy 查詢表.[B1]            '資料表:自動篩選出的資料 複製到 查詢表
  72.     End With
  73. End Sub
複製代碼

TOP

回復 18# lifedidi
卡在第71列 可能是2007 不接受這寫法 請修改如下
  1. Private Sub ComboBox2資料()  'ComboBox1有異動:尋找 [工種]欄位的字串
  2.     Dim D As Object
  3.     Set D = CreateObject("Scripting.Dictionary")
  4.     With 資料表
  5.         .AutoFilterMode = False
  6.         For Each a In .Range(.[A2], .[A2].End(xlDown))
  7.             
  8.             If a.Value = ComboBox1 Then D(a.Offset(, 1).Value) = ""
  9.             '符合ComboBox1 的 [工種]中-> 字典物件:D(Key) -> D(工種的字串)
  10.         Next
  11.        '** 以下程式碼將 字典物件:D(Key)的字串複製在最後一欄
  12.        '** 之後加以排序然後設為 ComboBox2.List
  13.        With .Columns(.Columns.Count).EntireColumn           'Sheet1的最後一欄
  14.             .Clear
  15.             .Cells(1).Resize(D.Count, 1) = Application.WorksheetFunction.Transpose(D.keys)
  16.             '*** 排序
  17.             .Cells(1).Resize(D.Count, 1).Sort Key1:=.Cells(1), Order1:=xlAscending, Header:= _
  18.                     xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
  19.                     SortMethod:=xlStroke, DataOption1:=xlSortNormal
  20.             '*******
  21.             ComboBox2.List = .Cells(1).Resize(D.Count, 1).Value  '工種選項內容
  22.             ComboBox2.Value = ComboBox2.List(0)                  '工種選項的值
  23.             '**
  24.         End With
  25.     End With
  26. End Sub
  27. Private Sub Show_資料()    '** 資料表中 自動篩選
  28.     With 資料表
  29.         .AutoFilterMode = False        '取消自動篩選-> 資料全部顯示出來:新篩選後的資料才會正確
  30.         If ComboBox1.ListIndex > -1 Then
  31.             .Range("A1").AutoFilter 1, ComboBox1            '自動篩選: 第一欄(A欄)的準則 為 ComboBox1
  32.             If ComboBox2.ListIndex > -1 Then
  33.                 .Range("A1").AutoFilter 2, ComboBox2        '自動篩選: 第一欄(A欄)的準則 為 ComboBox12
  34.             End If
  35.         End If
  36.         '.UsedRange.Range("A:C").Copy 查詢表.[B1]
  37.         .Range("A:C").Copy 查詢表.[B1]                       '資料表:自動篩選出的資料 複製到 查詢表
  38.     End With
  39. End Sub
複製代碼

.Range("A1").AutoFilter 1, ComboBox1   如圖


TOP

回復 20# lifedidi
請在附上檔案 看看

TOP

回復 22# lifedidi
自動 或 進階 篩選 資料庫的表頭 都不適宜有合併的儲存格
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 25# lifedidi
  1. Sub Ex()
  2.     Dim a
  3.     With [a1] '不清楚 With ????
  4.        ' .Parent (上一層的物件): 工作表
  5.         If .Parent.AutoFilterMode = False Then .AutoFilter
  6.         .AutoFilter Field:=2, Criteria1:=ComboBox1
  7.         'For Each a In .Columns(2).Cells.SpecialCells(12)
  8.         '上面 For 這裡有錯誤:直接跳到 Next 不會執行回圈
  9.         '如是 With ' [a1]->儲存格範圍 須改成如下
  10.         For Each a In .Parent.Columns(2).Cells.SpecialCells(xlCellTypeVisible)
  11.             If a <> "" Then
  12.                 d(a.Value) = ""
  13.             Else
  14.                 Exit For
  15.             End If
  16.         Next
  17.     End With
  18. End Sub
複製代碼
  1. SpecialCells 方法 傳回 Range 物件,此物件代表與指定型態及值相符合的所有儲存格。Range 物件。
  2. expression.SpecialCells(Type, Value)
  3. expression      必選。該運算式會傳回 [套用於] 清單中的其中一個物件。
  4. Type     必選的 XlCellType。要包含的儲存格。
  5. XlCellType 可以是這些 XlCellType 常數之一。
  6. xlCellTypeAllFormatConditions。  任何格式的儲存格
  7. xlCellTypeAllValidation。具有驗證準則的儲存格
  8. xlCellTypeBlanks。空儲存格
  9. xlCellTypeComments。包含註解的儲存格
  10. xlCellTypeConstants。包含常數的儲存格
  11. xlCellTypeFormulas。包含公式的儲存格
  12. xlCellTypeLastCell。已用範圍的最後一個儲存格
  13. xlCellTypeSameFormatConditions。  有相同格式的儲存格
  14. xlCellTypeSameValidation。  有相同驗證準則的儲存格
  15. xlCellTypeVisible。所有可見儲存格
複製代碼


感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 28# lifedidi
  1. Option Explicit
  2. Private Sub UserForm_Initialize()
  3.     Dim A As Date
  4.     TextBox1.Value = "8:00"
  5.     TextBox2.Value = "12:00"
  6.     TextBox3 = Val(TextBox2) - Val(TextBox1)
  7.     'TextBox3 = Format(CDate(TextBox2) - CDate(TextBox1), "H:M")
  8.     'A = CDate(TextBox2) - CDate(TextBox1)
  9.     'TextBox3 = A
  10. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 30# lifedidi
  1. Option Explicit
  2. Private Sub TextBox1_Change()
  3.     計時
  4. End Sub
  5. Private Sub TextBox2_Change()
  6.     計時
  7. End Sub
  8. Private Sub 計時()
  9.     'TextBox3控制項 請改成Label控制項為佳
  10.     If IsDate(TextBox1) And IsDate(TextBox2) Then
  11.         TextBox3 = Format(CDate(TextBox2) - CDate(TextBox1), "HH:MM")
  12.         'Label1.Caption = Format(CDate(TextBox2) - CDate(TextBox1), "HH:MM")
  13.     Else
  14.         TextBox3 = ""
  15.       '  Label1.Caption = ""
  16.     End If
  17. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

        靜思自在 : 真正的愛心,是照顧好自己的這顆心。
返回列表 上一主題