スキルアップ・問題解決なら、モーグにおまかせ！

お世話になっております。
先日は質問に対して回答いただき誠にありがとうございました。
別件でまた躓いてしまい、ご教示いただきたくご相談となります。
 
現在、検索ツールを作成しております。
検索する表はA列（A8）〜O列（O最終行）までの表です。
「検索」ボタンを押した際にオートフィルターで検索にヒットした行だけが表示されるようにはできたのですが、検索用セルに入力規則を設定するところが上手くいかず困っております。。。
 
セルC3〜C5を検索用セルとして、以下のように定義しております。
C3：LstsheetNo　'シート番号検索用セル　⇒　B列のシート番号検索用
C4：Lstgennryou '原料名検索用セル　⇒　D列の原料名検索用
C5：Lstseihinnmei '製品検索用セル　⇒　F列の製品名検索用
 
＜やりたいこと＞
上記検索用セルにそれぞれ入力規則を以下のように設定したい。
�@重複する項目は1件のみ表示されるようにしたい
�A可視化セルのみ表示されるようにしたい（＝検索で絞った際にその時に表示されている可視化セルのみが入力規則に表示されるようにしたい）
 
 

' 検索用セルにプルダウンを設定
Dim LstsheetNo As String
Dim Lstgennryou As String
Dim Lstseihinnmei As String
Range("C3:C5").ClearContents
        
'検索用セル初期化
LstsheetNo = ""
Lstgennryou = ""
Lstseihinnmei = ""

Dim 可視化セル最終行 As Long
可視化セル最終行 = Cells(Rows.Count, 2).End(xlUp).Row  
Dim MyDatasheetNo  As New Collection
Dim MyDatagennryou  As New Collection
Dim MyDataseihinnmei  As New Collection
Dim i As Long

'シート番号
On Error Resume Next    'データを登録する間、エラーを無視する
For i= 9 To 可視化セル最終行
　MyDatasheetNo.Add Cells(i, 2).Value, Cells(i, 2).Value
   Next i
On Error GoTo 0

'原料名
On Error Resume Next    'データを登録する間、エラーを無視する
For i= 9 To 可視化セル最終行
　MyDatagennryou.Add Cells(i, 4).Value, Cells(i, 4).Value
   Next i
On Error GoTo 0

'製品名
On Error Resume Next    'データを登録する間、エラーを無視する
For i= 9 To 可視化セル最終行
　MyDataseihinnmei.Add Cells(i, 6).Value, Cells(i, 6).Value
   Next i
On Error GoTo 0

'リストを取得       
Dim strsheetNo As String, j As Integer
For Each Var In MyDatasheetNo
　 j= j+ 1
　strsheetNo = strsheetNo & Var & ","
Next Var

Dim strgennryou As String
For Each Var In MyDatagennryou
　 j= j+ 1
　strgennryou= strgennryou & Var & ","
Next Var

Dim strseihinnmei As String
For Each Var In MyDataseihinnmei
　 j= j+ 1
　strseihinnmei = strseihinnmei & Var & ","
Next Var

'検索用セルに入力規則設定
Range("C3").Select
With Selection.Validation
　'入力規則の削除j
　.Delete
　'文字列の追加
　.Add Type:=xlValidateList, Formula1:="" & strsheetNo & ""
End With

Range("C4").Select
With Selection.Validation
　'入力規則の削除j
　.Delete
　'文字列の追加
　.Add Type:=xlValidateList, Formula1:="" & strgennryou& ""
End With

Range("C5").Select
With Selection.Validation
　'入力規則の削除j
　.Delete
　'文字列の追加
　.Add Type:=xlValidateList, Formula1:="" & strseihinnmei & ""
End With

'For Next 構文で入力されているすべての行において以下のループ処理を行う。
For i = 9 To B列最終行
'既にリストに挿入された値が元の"分類"に一致するものがあれば項目を追加しない。
If InStr(LstsheetNo, Cells(i, "B")) = 0 Then
LstsheetNo = LstsheetNo & "," & Cells(i, "B")
End If
                
If InStr(Lstgennryou, Cells(i, "D")) = 0 Then
Lstgennryou = Lstgennryou & "," & Cells(i, "D")
End If
                
If InStr(Lstseihinnmei, Cells(i, "F")) = 0 Then
Lstseihinnmei = Lstseihinnmei & "," & Cells(i, "F")
End If
Next

'検索用セルに入力規則設定
Range("C3").Select
With Selection.Validation
　'入力規則の削除j
　.Delete
　'文字列の追加
　.Add Type:=xlValidateList, Formula1:="" & LstsheetNo & ""
End With

Range("C4").Select
With Selection.Validation
　'入力規則の削除j
　.Delete
　'文字列の追加
　.Add Type:=xlValidateList, Formula1:="" & Lstgennryou & ""
End With

Range("C5").Select
With Selection.Validation
　'入力規則の削除j
　.Delete
　'文字列の追加
　.Add Type:=xlValidateList, Formula1:="" & Lstseihinnmei & ""
End With

オートフィルタの結果が次のようになっていて、重複を除いたB列の要素をもとに、
入力規則をD1セルに設定する例で説明します。
 

      A列   B列      C列      D列
1行   item1 item2
3     b     l
5     b     n
7     b     p
8     b     n

Sub test()
    Dim dic     As Object
    Dim rng     As Range
    Dim body    As Range
    Dim r       As Range

    Set dic = CreateObject("Scripting.Dictionary")
    Set rng = ActiveSheet.AutoFilter.Range
    Set body = Intersect(rng, rng.Offset(1))
    
    '2列目の可視セルを重複を除いて、dictionaryのキーに取得する
    For Each r In body.Columns(2).SpecialCells(xlCellTypeVisible)
        dic(r.Value) = Empty
    Next
    
    '入力規則をD1セルに設定します。
    '（基本的にマクロ記録そのままにしています。要否に応じて削って下さい）
    With Range("D1").Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
             Operator:=xlBetween, _
             Formula1:=Join(dic.keys, ",")
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .IMEMode = xlIMEModeNoControl
        .ShowInput = True
        .ShowError = True
    End With
End Sub

質問者さんのコードを活かすとしたら、こんな形になるのかもしれません。
 

' 検索用セルにプルダウンを設定
Sub test()
    Range("C3:C5").ClearContents

    Dim 可視セル最終行 As Long
    Dim 可視セル範囲 As Range

    可視セル最終行 = Cells(Rows.Count, 2).End(xlUp).Row
    Set 可視セル範囲 = Range("A9", Cells(可視セル最終行, 6))
    Set 可視セル範囲 = 可視セル範囲.SpecialCells(xlCellTypeVisible)

    Dim mylist  As String
    'シート番号
    mylist = getLists(2, 可視セル範囲)
    Call setValidationList(Range("C3"), mylist)
    
    '原料名
    mylist = getLists(4, 可視セル範囲)
    Call setValidationList(Range("C4"), mylist)
    
    '製品名
    mylist = getLists(6, 可視セル範囲)
    Call setValidationList(Range("C5"), mylist)
End Sub

Function getLists(n As Long, 可視セル範囲 As Range) As String
    Dim myCollection As New Collection
    Dim r As Range
    
    On Error Resume Next
    For Each r In Intersect(可視セル範囲, Columns(n)).Cells
        myCollection.Add r.Value, r.Value
    Next
    On Error GoTo 0
    
    Dim s As String, v  As Variant
    For Each v In myCollection
        s = s & v & ","
    Next
    getLists = Left(s, Len(s) - 1)      '尻尾の","を取る
End Function

Function setValidationList(rng As Range, list As String)
    With rng.Validation
        .Delete
        .Add Type:=xlValidateList, Formula1:=list
    End With
End Function

Dictionaryを利用したバージョンも併せて書いておきます。参考にしてください。

Sub test2()
    Dim rng     As Range
    Dim body    As Range
    Dim r       As Range

    Set rng = ActiveSheet.AutoFilter.Range
    Set body = Intersect(rng, rng.Offset(1))

    'シート番号
    Call setValidationLists(body, 2, Range("C3"))
    '原料名
    Call setValidationLists(body, 4, Range("C4"))
    '製品名
    Call setValidationLists(body, 6, Range("C5"))
End Sub

'col列の可視セルを対象に、重複を除いたリストを rngセルの入力規則にセット
Function setValidationLists(body As Range, col As Long, rng As Range)
    Dim dic As Object
    Dim r As Range
    
    Set dic = CreateObject("Scripting.Dictionary")
    For Each r In body.Columns(col).SpecialCells(xlCellTypeVisible)
        dic(r.Value) = Empty
    Next
    With rng.Validation
        .Delete
        .Add Type:=xlValidateList, Formula1:=Join(dic.keys, ",")
    End With
End Function

simple様
お世話になっております。
お返事が遅くなり申し訳ございませんでした。
前回の質問の際にもお答えいただき、今回もわかりやすくご説明いただき
本当にありがとうございます（泣）感謝しかありません。
dictionaryというデータ構造について、とても勉強になりました。
ご教示いただいたコードで実行したところ、やりたかったことが実現できました！！！
本当にありがとうございました。
また、わたしが書いたコードを活かした場合のコードもご教示いただきありがとうございます。
こちらも確認しながら勉強していきたいと思います。
 
この度も本当にありがとうございました！！！！！