[已解决]数据有效性去除重复项，代码已经有了，但是需要大侠帮忙修改一下

cpl275538

代码内容：With Range("A2:A100")引用范围是当前表格A2:A100
希望能修改为：引用范围改为另一个表，例如Sheet2!A2:A100，请问如何修改
以下为代码：
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   Dim RowNum, ListRows, ListStartRow, ListColumn As Integer
   Dim TheList As String
   Dim Repeated As Boolean
   If Target.Column <> 4 Then Exit Sub
   With Range("A2:A100")
      ListRows = .Rows.Count
      ListStartRow = .Row
      ListColumn = .Column
   End With
   For RowNum = 0 To ListRows - 1
      Repeated = False
      If Not IsEmpty(Cells(ListStartRow + RowNum, ListColumn)) Then
        For i = 0 To RowNum - 1
          If Cells(ListStartRow + RowNum, ListColumn) = Cells(ListStartRow + i, ListColumn) Then
            Repeated = True
            Exit For
          End If
        Next i
        If Not Repeated Then TheList = TheList & Cells(ListStartRow + RowNum, ListColumn) & ","
      End If
   Next RowNum
   TheList = Left(TheList, Len(TheList) - 1)
   With Range("$D$2").Validation
      .Delete
      .Add _
      Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=TheList
   End With
End Sub

最佳答案

月排行榜 / 总排行榜

grf1973

2017-7-14 16:31

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   Dim TheList As String, i&
   If Intersect(Target, [d2:d10]) Is Nothing Then Exit Sub
   Set d = CreateObject("scripting.dictionary")
   arr = Range("a2:a" & [a65536].End(3).Row)
   For i = 1 To UBound(arr)
      If Len(arr(i, 1)) And InStr(TheList & ",", "," & arr(i, 1) & ",") = 0 Then TheList = TheList & "," & arr(i, 1)
   Next
   
   With Target.Validation
      .Delete
      .Add xlValidateList, , , Mid(TheList, 2)
   End With
End Sub

跳转到最佳答案楼层

grf1973

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   If Target.Address <> "$D$2" Then Exit Sub
   Set d = CreateObject("scripting.dictionary")
   arr = Range("a2:a" & [a65536].End(3).Row)
   For i = 1 To UBound(arr)
      If Len(arr(i, 1)) Then d(arr(i, 1)) = ""
   Next
   
   With Range("D2").Validation
      .Delete
      .Add _
      Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=Join(d.keys, ",")
   End With
End Sub

grf1973

再上个不用字典的。

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2.    Dim TheList As String, i&
   
3.    If Target.Address <> "$D$2" Then Exit Sub
   
4.    Set d = CreateObject("scripting.dictionary")
   
5.    arr = Range("a2:a" & [a65536].End(3).Row)
   
6.    For i = 1 To UBound(arr)
   
7.       If Len(arr(i, 1)) And InStr(TheList & ",", "," & arr(i, 1) & ",") = 0 Then TheList = TheList & "," & arr(i, 1)
   
8.    Next
   
9.    
   
10.    With Range("D2").Validation
    
11.       .Delete
    
12.       .Add _
    
13.       Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=Mid(TheList, 2)
    
14.    End With
    
15. End Sub

复制代码

grf1973

哦，问得不是这个。
如果只是要解决数据引用范围，把Range("A2:A100")改为Sheet2.Range("A2:A100")即可。

arr = Sheet2.Range("a2:a" & Sheet2.[a65536].End(3).Row)

砂海

"
代码内容：With Range("A2:A100")引用范围是当前表格A2:A100
希望能修改为：引用范围改为另一个表，例如Sheet2!A2:A100，请问如何修改
                                               "
这样就可以:
With sheets("Sheet2").Range("A2:A100")

cpl275538

grf1973 发表于 2017-7-14 14:57
再上个不用字典的。

用了您的代码确实把引用范围改到sheet2表了，但您这个代码只在$D$2单元设置下拉选项，我想在D2:D10都设置这个下拉选项，可以吗？试着删除掉这句 If Target.Address <> "$D$2" Then Exit Sub，  这样有没有限制所有都可以设置下来

grf1973

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   Dim TheList As String, i&
   If Intersect(Target, [d2:d10]) Is Nothing Then Exit Sub
   Set d = CreateObject("scripting.dictionary")
   arr = Range("a2:a" & [a65536].End(3).Row)
   For i = 1 To UBound(arr)
      If Len(arr(i, 1)) And InStr(TheList & ",", "," & arr(i, 1) & ",") = 0 Then TheList = TheList & "," & arr(i, 1)
   Next
   
   With Target.Validation
      .Delete
      .Add xlValidateList, , , Mid(TheList, 2)
   End With
End Sub

cpl275538

grf1973 发表于 2017-7-14 16:31
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   Dim TheList As String, i&
   If In ...

非常感谢，我还一个问题希望您能帮忙，拜谢!
详见附件，D列是对sheet2表A列的选择，当选好D列后，E选择sheet2表B列，例如E2选项是A,B   E3选项是C,D  同样不重复，能否实现？非常感谢

grf1973

请看附件，就是一个简单的二级菜单。

cpl275538

grf1973 发表于 2017-7-16 20:38
请看附件，就是一个简单的二级菜单。

非常感谢老师的不吝赐教，拜谢，拜谢，拜谢。
一再麻烦您的实在不好意思，是我自己把问题复杂化了（一一分解了让您回答），但发现您可以一次达到目的，所以请您再出手一次帮忙把我这个问题彻底解决Sheet2的C列是一级菜单，D列是二级菜单1，E列是二级菜单2，F列是二级菜单3，
在Sheet1的B列生成一级菜单选项，C列生成二级菜单1选项,D列生成二级菜单2选项,E列生成二级菜单3选项
这些二级菜单都是对应一级菜单生成的，并非四级菜单（昨天您给的是一个二级菜单，现在是3个二级菜单）
再次拜谢!