先不重複篩選後，並自動設為下拉式選單 - Excel程式區

帖子: 129
主題: 25
精華: 0
積分: 159
點名: 0
作業系統: win7
軟體版本: office2010
閱讀權限: 20
性別: 男
註冊時間: 2011-12-24
最後登錄: 2022-12-12

13^#

發表於 2020-5-19 23:54 | 只看該作者

本帖最後由 iceandy6150 於 2020-5-19 23:56 編輯

1) 如果表2的C欄都是不重覆的, 那直接用這來設定第三層選單,
又如果資料並不變動或變動少, 則可固定範圍定義名稱,
若時有變動(重點:不重覆), 用動態定義名稱即可解決, 何須每次都要跑VBA迴圈!!!
這樣用FIND就可定位找出前兩層資料~
2) 如果C欄是會重覆的, 那用第三層選單找對應的前兩層, 就不是那麼準確,
何況如果C欄有幾百或上千行, 每次都要從長又長的選單中去選取所要的, 滑鼠滑上滑下__並不太聰明,也容易選錯重來;
再則, 幾百上千行的內容用字典檔擠成字串, 再塞進清單中, 會不會超過文字長度限制???

回復 10# 准提部林

版大您好，關於這次程式需求的部分，我略做說明一下

三層式下拉選單，我有搜尋過網路
有個做法也是要先把類別表，從直的轉成橫的，之後再去做處理
但是因為我也是幫忙同事處理的，怕以後參照表有變動(新增或刪減)，可能同事就不會操作了
所以我要寫一個...按下按鈕就會通通自己完成的檔案

而且A部門的人，參照表也許有15種。但是B部門的人，參照表也許只有12種。C部門的有26種...等等
所以我希望檔案給他們後，他們只要會增減參照表，剩下的，我的按鈕都會幫他們設定好好的，方便使用

參照表的C欄 (用途類別) 應該是絕對不重覆的。
A欄是大分類，所以在表中很多重覆
B欄是中分類，所以有一些重覆，更討厭的是有一些類別還是空的
C欄是小分類，所以應該必定不會重覆，不然帳就會出錯了

然後...為什麼不要做...先A欄下拉式大分類，之後B欄會剩下相對應的分類，最後剩下C欄的分類
正常來講一般比如說在搜尋料件或倉儲，應該是這樣比較快
但是我這邊報帳表，是不能選錯的
比如，A選到3大類，B選3中類，C卻選去1小類---(這樣帳的科目就錯了)

所以，這樣東西是 A的3 那肯定是B的3 肯定是C的3 (就是整個表的第3列的ABC)
本來是很想叫同事在填的時候，乾脆自己跳去Sheet("參照表")，複製ABC看哪一列，再回來貼上值就好
但是又怕他們把參照表弄亂了
只好想出....只要下拉選擇C欄，經過查照功能，自動幫你放入....相對應的A跟B
所以才想出我那個檔案的做法 (很土炮...)

以目前公司的狀況，參照表的C欄，要報帳的科目應該是不會超過30~50樣

感謝版大的熱心教學

哈囉~大家好呀

帖子: 129
主題: 25
精華: 0
積分: 159
點名: 0
作業系統: win7
軟體版本: office2010
閱讀權限: 20
性別: 男
註冊時間: 2011-12-24
最後登錄: 2022-12-12

12^#

發表於 2020-5-19 23:32 | 只看該作者

回復 9# n7822123

哇賽~~~龍大你這個太屌了吧
我土炮方法想了好久，繞了好幾圈，才做出這樣的功能
你沒幾行就做完了.....
能否教兩句? 想學...

(有搜尋ByVal Target As Range的用法，但還不是很懂，我們這版之前也有相關主題)
目前看來有兩大重點
1.觸發功能
2.塞字典功能

另外是，我只會插入AXTIVE的按鈕，裡面放程式碼
你那兩個按鈕...好像也不是按鈕，為什麼可以按啊? 真神奇

然後你還有建立了模組跟物件類別模組....
這我以前都沒有用過...

哈囉~大家好呀

n7822123

　暱稱: 阿龍

帖子: 406
主題: 8
精華: 0
積分: 453
點名: 0
作業系統: WINDOWS 7
軟體版本: 2007
閱讀權限: 20
性別: 男
來自: 台灣
註冊時間: 2015-2-7
最後登錄: 2021-7-31

11^#

發表於 2020-5-19 22:55 | 只看該作者

回復 10# 准提部林

幾百上千行的內容用字典檔擠成字串, 再塞進清單中, 會不會超過文字長度限制???

回準大~原來字典的Key 與 item 都可以是 String，而String 最多可裝大約 20 億 ( 2^31)個字元。

而此做法每個item 已不是 String，變成物件，物件又可以定義多個屬性，每個屬性都可以是String

只要單一 String 變數不超過 20 億 ( 2^31)個字元，就不會有問題。

至於字典 key的數量與物件能擴充的屬性數量，網路上查不到相關資訊

不過我猜字典跟陣列一樣，是虛擬的，能裝多少東西取決於"電腦記憶體"

如此行程式 Arr = Range([A1], Cells(Rows.Count, Columns.Count))

使用新版Excel 的人執行這行基本上都會跳出 "記憶體不足" (除非你電腦記憶體非常大)

程式是依需求寫的，需求表達不清楚
或者沒有上傳附件，愛莫能助

版主 Rank: 7 Rank: 7 Rank: 7

准提部林

帖子: 2808
主題: 10
精華: 0
積分: 2864
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-5-19

10^#

發表於 2020-5-19 15:55 | 只看該作者

1) 如果表2的C欄都是不重覆的, 那直接用這來設定第三層選單,
又如果資料並不變動或變動少, 則可固定範圍定義名稱,
若時有變動(重點:不重覆), 用動態定義名稱即可解決, 何須每次都要跑VBA迴圈!!!
這樣用FIND就可定位找出前兩層資料~
2) 如果C欄是會重覆的, 那用第三層選單找對應的前兩層, 就不是那麼準確,
何況如果C欄有幾百或上千行, 每次都要從長又長的選單中去選取所要的, 滑鼠滑上滑下__並不太聰明,也容易選錯重來;
再則, 幾百上千行的內容用字典檔擠成字串, 再塞進清單中, 會不會超過文字長度限制???

n7822123

　暱稱: 阿龍

帖子: 406
主題: 8
精華: 0
積分: 453
點名: 0
作業系統: WINDOWS 7
軟體版本: 2007
閱讀權限: 20
性別: 男
來自: 台灣
註冊時間: 2015-2-7
最後登錄: 2021-7-31

9^#

發表於 2020-5-19 11:16 | 只看該作者

本帖最後由 n7822123 於 2020-5-19 11:17 編輯

回復 1# iceandy6150

【第二個自動化完美做法】
就是既然準則在[用途類別(科目)] --(工作表1的I欄)
那按下按鈕後
會自動把工作表1的I欄，設定下拉式清單，一次50列，來源是工作表2的H
然後I欄下拉選定某個值後
會自動把工作表1的H欄，填入工作表2對照表格中相對應的值
會自動把工作表1的G欄，填入工作表2對照表格中相對應的值
(連動的概念)

原來你的需求只是這麼簡單~ 10分鐘搞定
這我常常幫公司的同事做
不需命名名稱、不用函數
看你有沒有心想學別人的做法

xls版本是給舊版Excel的人使用的，
2007以後請開xlsm版本

自動設下拉式選單0519.rar (46.43 KB)

程式是依需求寫的，需求表達不清楚
或者沒有上傳附件，愛莫能助

帖子: 129
主題: 25
精華: 0
積分: 159
點名: 0
作業系統: win7
軟體版本: office2010
閱讀權限: 20
性別: 男
註冊時間: 2011-12-24
最後登錄: 2022-12-12

8^#

發表於 2020-5-18 23:09 | 只看該作者

本帖最後由 iceandy6150 於 2020-5-18 23:12 編輯

回復 6# 准提部林

版主您好，我後來想了個土方法

我知道可以選定一個大範圍，給他定義名稱
然後VLOOKUP這個函數只能找...一個範圍內，最左邊那欄當標準

所以原本 A欄 B欄 C欄，就複製到別的地方，變成C欄，B欄，A欄
然後VLOOKUP C欄，可以找到相對應的A跟B
(其實用FIND好像也可以)

至於下拉式選單的內容，因為進階篩選過後，把篩選過的範圍，定義名稱
再把這個名稱給下拉式選單 (來源為變數)
這邊要配合 INDIRECT 這個語法，才能正常使用，也是網路查到的

以下是程式碼
跟測試檔案
(目前自動產生下拉清單只設定5格)

Private Sub CommandButton1_Click()
Range("A2:C20").Select
Selection.ClearContents
With Selection.Validation
.Delete
.Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
:=xlBetween
.IgnoreBlank = True
.InCellDropdown = True
.IMEMode = xlIMEModeNoControl
.ShowInput = True
.ShowError = True
End With
Range("C2").Select
End Sub
'*******************************************************************************
Private Sub CommandButton2_Click()
Dim a, b, c, d
Sheets("工作表2").Select
With Sheets("工作表2")
'每次執行先將最右邊四欄砍光
.Columns(.Columns.Count).Delete Shift:=xlShiftLeft
.Columns(.Columns.Count - 1).Delete Shift:=xlShiftLeft
.Columns(.Columns.Count - 2).Delete Shift:=xlShiftLeft
.Columns(.Columns.Count - 3).Delete Shift:=xlShiftLeft
'[用途類別]先複製到最右邊倒數第三欄
.Columns("C:C").Select
Selection.Copy
Sheets("工作表2").Columns(.Columns.Count - 2).PasteSpecial (xlPasteAll)
Application.CutCopyMode = False
'[用途別]先複製到最右邊倒數第二欄
.Columns("B:B").Select
Selection.Copy
Sheets("工作表2").Columns(.Columns.Count - 1).PasteSpecial (xlPasteAll)
Application.CutCopyMode = False
'[工作計畫]先複製到最右邊倒數第一欄
.Columns("A:A").Select
Selection.Copy
Sheets("工作表2").Columns(.Columns.Count).PasteSpecial (xlPasteAll)
Application.CutCopyMode = False
'進階不重複篩選--放到...最右邊倒數第四欄
.Columns("C:C").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Columns(.Columns.Count - 3), Unique:=True
Application.CutCopyMode = False
a = Sheets("工作表2").Columns(.Columns.Count - 3).End(xlDown).Row '查看(科目)有多少個數量
b = .Columns.Count - 3 'b為第幾欄(最右邊倒數第四欄)
'設定--定義範圍
ActiveWorkbook.Names.Add Name:="abc", RefersToR1C1:="=工作表2!R2C" & b & ":R" & a & "C" & b
ActiveWorkbook.Names("abc").Comment = ""
'設定下拉式清單
Sheets("工作表1").Select
Range("C2").Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=INDIRECT(""abc "")"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.IMEMode = xlIMEModeNoControl
.ShowInput = True
.ShowError = True
End With
'複製下拉式清單到別格
Selection.AutoFill Destination:=Range("C2:C5"), Type:=xlFillDefault
'設定定義範圍
a = Sheets("工作表2").Columns(.Columns.Count - 2).End(xlDown).Row '查看這張參照表有多少[用途類別]，這張表的底部到多低
b = .Columns.Count - 2 'b為第幾欄(最右邊倒數第三欄...[用途類別])
Sheets("工作表2").Select
ActiveWorkbook.Names.Add Name:="data", RefersToR1C1:="=工作表2!R2C" & b & ":R" & a & "C" & (b + 2) '這個範圍有三欄，從b到b+2
ActiveWorkbook.Names("data").Comment = ""
'設定自動出現-方法2，若對照表中為空格，顯示空格，若工作類別(科目)未選，顯示空格
'(從定義好的範圍data中去找到範圍中的第2欄，放到B2---B2要放用途別，data的第2欄也是用途別)
'先設定[用途別]
Sheets("工作表1").Select
Range("B2").Select
ActiveCell.FormulaR1C1 = _
"=IFERROR(IF(VLOOKUP(RC3,data,2,0)=0,"""",VLOOKUP(RC3,data,2,0)),"""")"
'複製公式到別格
Selection.AutoFill Destination:=Range("B2:B5"), Type:=xlFillDefault
'再設定[工作計畫]---A2要放用[工作計畫]，data的第3欄也是[工作計畫])
Sheets("工作表1").Select
Range("A2").Select
ActiveCell.FormulaR1C1 = _
"=IFERROR(IF(VLOOKUP(RC3,data,3,0)=0,"""",VLOOKUP(RC3,data,3,0)),"""")"
'複製公式到別格
Selection.AutoFill Destination:=Range("A2:A5"), Type:=xlFillDefault
End With
Range("C2").Select
End Sub

複製代碼

自動設下拉式選單.rar (31.51 KB)

感謝各位

哈囉~大家好呀

帖子: 129
主題: 25
精華: 0
積分: 159
點名: 0
作業系統: win7
軟體版本: office2010
閱讀權限: 20
性別: 男
註冊時間: 2011-12-24
最後登錄: 2022-12-12

7^#

發表於 2020-5-18 23:03 | 只看該作者

回復 5# n7822123

感謝你的幫忙，我自己後來有找到方法了，會貼在最下面的回應
再與大大您分享交流

哈囉~大家好呀

版主 Rank: 7 Rank: 7 Rank: 7

准提部林

帖子: 2808
主題: 10
精華: 0
積分: 2864
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-5-19

6^#

發表於 2020-5-18 13:35 | 只看該作者

回復 3# iceandy6150

想用第三層選單, 往回推算前兩層相關聯文字, 再自動填入???
問題:第三層選單所對應的有兩個以上, 如何判斷屬于哪一個???

2樓給的是漸進式的動態選單, 選第一層後, 自動判斷第二層清單, 再至第三層,
越選越少, 也不須打字!!!

至于表1, 可預建1~200列驗證清單,
輸入完成-轉出後, 用CLEARCONTENTS清空內容, 即可繼續輸入新的資料,
幾行程式碼即可~~

=========================

n7822123

　暱稱: 阿龍

帖子: 406
主題: 8
精華: 0
積分: 453
點名: 0
作業系統: WINDOWS 7
軟體版本: 2007
閱讀權限: 20
性別: 男
來自: 台灣
註冊時間: 2015-2-7
最後登錄: 2021-7-31

5^#

發表於 2020-5-18 12:55 | 只看該作者

回復 4# n7822123

原寫法有瑕疵，未考慮項目可能有互相包含的字串

修正如下 (紅色部分)

Sub 下拉選單()

'工作表2的A欄
Arr = Range([工作表2!A2], [工作表2!A65535].End(3))
List$ = ""
For R = 1 To UBound(Arr)  '去除重複
  If InStr("," & List & ",", "," & Arr(R, 1) & ",") = 0 Then List = List & "," & Arr(R, 1)
Next
With [G2:G100].Validation  '下拉格式的範圍自己改
  .Delete
  .Add Type:=xlValidateList, Operator:=xlBetween, Formula1:=List
End With

'工作表2的B欄
Arr = Range([工作表2!B2], [工作表2!B65535].End(3))
List = ""
For R = 1 To UBound(Arr)  '去除重複
  If InStr("," & List & ",", "," & Arr(R, 1) & ",") = 0 Then List = List & "," & Arr(R, 1)
Next
With [H2:H100].Validation  '下拉格式的範圍自己改
  .Delete
  .Add Type:=xlValidateList, Operator:=xlBetween, Formula1:=List
End With

'工作表2的C欄
Arr = Range([工作表2!C2], [工作表2!C65535].End(3))
List = ""
For R = 1 To UBound(Arr)  '去除重複
  If InStr("," & List & ",", "," & Arr(R, 1) & ",") = 0 Then List = List & "," & Arr(R, 1)
Next
With [I2:I100].Validation  '下拉格式的範圍自己改
  .Delete
  .Add Type:=xlValidateList, Operator:=xlBetween, Formula1:=List
End With

End Sub

程式是依需求寫的，需求表達不清楚
或者沒有上傳附件，愛莫能助