[已解决]发现二义性的名称 Worksheet_SelectionChange 求把两个代码合并

cpl275538

由于“发现二义性的名称 Worksheet_SelectionChange”所以要求合并这个两个代码，求大侠帮忙
代码一：鼠标点击A2至A100范围内任意单元格,则在A1显示该单元格内容。
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim rng As Range, rg As Range, Arr, i&, j&
Set rng = [a2:a100]
If Intersect(rng, Target) Is Nothing Then Exit Sub
[A1] = Target.Value

End Sub

代码二：在B2至B100范围内设置下拉选项,选择Sheet2表A列的内容。
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   Dim TheList As String, i&
   If Intersect(Target, [b2:b100]) Is Nothing Then Exit Sub
   Set d = CreateObject("scripting.dictionary")
   Arr = Sheet2.Range("a2:a" & Sheet2.[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


请帮忙合并,感谢

最佳答案

月排行榜 / 总排行榜

苏子龙

2017-7-15 15:08

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2.    Dim TheList As String, i&
   
3.    If Not Intersect(Target, [a2:a100]) Is Nothing Then [a1] = Target.Value
   
4.    If Intersect(Target, [b2:b100]) Is Nothing Then Exit Sub
   
5.    Set d = CreateObject("scripting.dictionary")
   
6.    Arr = Sheet2.Range("a2:a" & Sheet2.[a65536].End(3).Row)
   
7.    For i = 1 To UBound(Arr)
   
8.       If Len(Arr(i, 1)) Then d(Arr(i, 1)) = ""
   
9.    Next
   
10.    
    
11.    With Target.Validation
    
12.       .Delete
    
13.       .Add xlValidateList, , , Join(d.keys, ",")
    
14.    End With
    
15. End Sub

复制代码

用字典去重复

跳转到最佳答案楼层

苏子龙

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   Dim TheList As String, i&
   If Not Intersect(Target, [a2:a100]) Is Nothing Then [a1] = Target.Value
   If Intersect(Target, [b2:b100]) Is Nothing Then Exit Sub
   Set d = CreateObject("scripting.dictionary")
   Arr = Sheet2.Range("a2:a" & Sheet2.[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

苏子龙

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2.    Dim TheList As String, i&
   
3.    If Not Intersect(Target, [a2:a100]) Is Nothing Then [a1] = Target.Value
   
4.    If Intersect(Target, [b2:b100]) Is Nothing Then Exit Sub
   
5.    Set d = CreateObject("scripting.dictionary")
   
6.    Arr = Sheet2.Range("a2:a" & Sheet2.[a65536].End(3).Row)
   
7.    For i = 1 To UBound(Arr)
   
8.       If Len(Arr(i, 1)) Then d(Arr(i, 1)) = ""
   
9.    Next
   
10.    
    
11.    With Target.Validation
    
12.       .Delete
    
13.       .Add xlValidateList, , , Join(d.keys, ",")
    
14.    End With
    
15. End Sub

复制代码

用字典去重复