如何从动态来源添加数据有效性序列？

OALD

lsdongjh 发表于 2018-8-31 14:15

试了您的代码，因为您用了"|"来做为分隔符，和“FoldersGet”工作表的G列的值里原有的"|"会混在一起，所以得到的筛选下拉菜单是把G列的值进一步拆分开的。我试着把代码里的"|"改成“~”，有出现一个新的问题，就是“Documents”工作表D中，单元格D1，D2，D3的下拉菜单应该只有一个选项，结果是相同的选项重复了两次，是不是字典有什么小问题？

lsdongjh

本身字典的选项就没有去重。如果要去重，需要对Item进行替换后再加入

lsdongjh

1. Option Explicit
   
2. 
   
3. Sub Test()
   
4.     Dim strShName As String
   
5.     Dim shFolder As Worksheet, shDoc As Worksheet, objList As Object
   
6.     Dim arr As Variant
   
7.     Dim lngRow As Long
   
8.     Dim strID As String, strList As String, strSplit() As String, strItem As String
   
9.     Dim arrKeys As Variant, arrItems As Variant
   
10.     Dim Rg As Range
    
11.    
    
12.     strShName = "FoldersGet"
    
13.     Set shFolder = Sheets(strShName)
    
14.     Set shDoc = Sheets("Documents")
    
15.    
    
16.     arr = shFolder.UsedRange
    
17.     Set objList = CreateObject("Scripting.Dictionary")
    
18.    
    
19.     For lngRow = 2 To UBound(arr)
    
20.         strID = Trim(arr(lngRow, 5))
    
21.         strList = "@" & arr(lngRow, 7) & "@"
    
22.         strItem = objList(strID)
    
23.         strItem = Replace(strItem, strList, "")
    
24.         strItem = strItem & strList
    
25.         objList(strID) = strItem
    
26.     Next
    
27.    
    
28.     arrKeys = objList.keys
    
29.     arrItems = objList.items
    
30.    
    
31.     Set Rg = shFolder.Range("O1") '将O列当作来源列
    
32.     For lngRow = LBound(arrItems) To UBound(arrItems)
    
33.         strItem = arrItems(lngRow)
    
34.         strItem = Mid(strItem, 2, Len(strItem) - 2)
    
35.         strSplit = Split(strItem, "@@")
    
36.         Rg.Resize(UBound(strSplit) + 1, 1) = Application.WorksheetFunction.Transpose(strSplit)
    
37.         strID = arrKeys(lngRow)
    
38.         strList = "=" & strShName & "!" & Rg.Resize(UBound(strSplit) + 1, 1).Address
    
39.         Set Rg = Rg.Offset(UBound(strSplit) + 1, 0)
    
40.         objList(strID) = strList
    
41.     Next
    
42.    
    
43.     lngRow = shDoc.Range("C" & Rows.Count).End(xlUp).Row
    
44.     arr = shDoc.Range("C1:C" & lngRow)
    
45.    
    
46.     For lngRow = 2 To UBound(arr)
    
47.         strID = Trim(arr(lngRow, 1))
    
48.         If strID <> "" Then strList = objList(strID)
    
49.         With shDoc.Cells(lngRow, 4).Validation
    
50.             .Delete
    
51.             .Add Type:=xlValidateList, Formula1:=strList
    
52.         End With
    
53.     Next
    
54.    
    
55. End Sub

复制代码

OALD

lsdongjh 发表于 2018-9-4 14:25

问题终于解决了，谢谢lsdongjh老师的耐心指导！您的水平真棒！：）