[已解决]数据有效性序列问题

心灵之舞

根据B1、C1中数据，设置D1有效性不重复数据序列，B1、C1不建立有效性序列，请论坛的老师们帮助回答，谢谢！ 数据有效性去重联动1.rar (11.07 KB, 下载次数: 35)

2014-10-19 20:56 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

dsmch

2014-10-19 22:25

Sub aa()
Set d = CreateObject("scripting.dictionary")
arr = Range("a3").CurrentRegion
For i = 2 To UBound(arr)
    zf = arr(i, 2) & "," & arr(i, 3)
    If Not d.exists(zf) Then
        d(zf) = arr(i, 4)
    Else
       If InStr("," & d(zf) & ",", "," & arr(i, 4) & ",") = 0 Then d(zf) = d(zf) & "," & arr(i, 4)
    End If
Next
End Sub

跳转到最佳答案楼层

su45

D1要的是什么数据？

心灵之舞

su45 发表于 2014-10-19 21:16
D1要的是什么数据？

查询B1为B列内容，C1为C列内容，D1为D列内容。根据B1、C1、查询D列取不重复数据，生成序列！我的文件中有一段代码，但总是报错，不知如何修改，还请帮忙看看！谢谢！

dsmch

1. Private Sub Workbook_Open()
   
2. '打开工作簿，执行aa,给字典赋值，避免反复调用
   
3. Call aa
   
4. End Sub
   
5. Public d, arr
   
6. Sub aa()
   
7. Set d = CreateObject("scripting.dictionary")
   
8. arr = Range("a3").CurrentRegion
   
9. For i = 2 To UBound(arr)
   
10.     zf = arr(i, 2) & "," & arr(i, 3)
    
11.     If Not d.exists(zf) Then d(zf) = arr(i, 4) Else d(zf) = d(zf) & "," & arr(i, 4)
    
12. Next
    
13. End Sub
    
14. Private Sub Worksheet_Change(ByVal Target As Range)
    
15. If Not Application.Intersect([b1:c1], Target) Is Nothing Then
    
16.         [d1].ClearContents
    
17.         With [d1].Validation
    
18.             .Delete
    
19.             .Add Type:=xlValidateList, Formula1:=d([b1].Value & "," & [c1].Value)
    
20.         End With
    
21. End If
    
22. End Sub

复制代码

dsmch

………………

心灵之舞

dsmch 发表于 2014-10-19 21:32
………………

dsmch老师，您好！感谢您的帮助！在测试中发现D1序列中会出现重复的项，能否去重呀！

dsmch

Sub aa()
Set d = CreateObject("scripting.dictionary")
arr = Range("a3").CurrentRegion
For i = 2 To UBound(arr)
    zf = arr(i, 2) & "," & arr(i, 3)
    If Not d.exists(zf) Then
        d(zf) = arr(i, 4)
    Else
       If InStr("," & d(zf) & ",", "," & arr(i, 4) & ",") = 0 Then d(zf) = d(zf) & "," & arr(i, 4)
    End If
Next
End Sub

心灵之舞

谢谢dsmch老师！问题已解决！