[已解决]请帮忙把这个下面两个代码合并，非常感谢！

cpl275538

请帮忙把这个下面两个代码合并，非常感谢！
代码一：
Private Sub Worksheet_Change(ByVal Target As Range)
     If Target.Count > 1 Then Exit Sub
     If Intersect(Target, [b3:b70]) Is Nothing Then Exit Sub
     Target.Offset(, 1).Resize(, 4).Validation.Delete
     Target.Offset(, 1).Resize(, 4).ClearContents
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   Dim TheList As String, i&
   If Target.Count > 1 Then Exit Sub
   If Not Application.Intersect(Target, Range("A3:A500")) Is Nothing Then [a1] = Target: Exit Sub
   If Intersect(Target, [b3:e70]) Is Nothing Then Exit Sub
   Set d = CreateObject("scripting.dictionary")
   arr = Sheet2.Range("c3:f" & Sheet2.[c65536].End(3).Row)
   For i = 1 To UBound(arr)
      x = arr(i, 1)
      If Len(x) Then
        If InStr(d(x) & ",", "," & arr(i, Target.Column - 1) & ",") = 0 Then d(x) = d(x) & "," & arr(i, Target.Column - 1)
      End If
   Next

   TheList = IIf(Target.Column = 2, Join(d.keys, ","), Mid(d(Cells(Target.Row, 2).Value), 2))
   With Target.Validation
      .Delete
      If Len(TheList) Then .Add xlValidateList, , , TheList
   End With
End Sub


代码二：
Private Sub Worksheet_Change(ByVal Target As Range)
     If Target.Count > 1 Then Exit Sub
     If Intersect(Target, [j3:j70]) Is Nothing Then Exit Sub
     Target.Offset(, 1).Resize(, 4).Validation.Delete
     Target.Offset(, 1).Resize(, 4).ClearContents
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   Dim TheList As String, i&
   If Target.Count > 1 Then Exit Sub
   If Intersect(Target, [j3:m70]) Is Nothing Then Exit Sub
   Set d = CreateObject("scripting.dictionary")
   arr = Sheet5.Range("c3:f" & Sheet5.[c65536].End(3).Row)
   For i = 1 To UBound(arr)
      x = arr(i, 1)
      If Len(x) Then
        If InStr(d(x) & ",", "," & arr(i, Target.Column - 9) & ",") = 0 Then d(x) = d(x) & "," & arr(i, Target.Column - 9)
      End If
   Next

   TheList = IIf(Target.Column = 10, Join(d.keys, ","), Mid(d(Cells(Target.Row, 10).Value), 2))
   With Target.Validation
      .Delete
      If Len(TheList) Then .Add xlValidateList, , , TheList
   End With
End Sub

最佳答案

月排行榜 / 总排行榜

大灰狼1976

2017-7-18 16:39

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.      If Target.Count > 1 Then Exit Sub
   
3.      If Intersect(Target, [b3:b70]) Is Nothing Or Intersect(Target, [j3:j70]) Is Nothing Then Exit Sub
   
4.      Target.Offset(, 1).Resize(, 4).Validation.Delete
   
5.      Target.Offset(, 1).Resize(, 4).ClearContents
   
6. End Sub
   
7. 
   
8. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
9.    Dim TheList As String, i&
   
10.    If Target.Count > 1 Then Exit Sub
    
11.    If Not Application.Intersect(Target, Range("A3:A500")) Is Nothing Then [a1] = Target: Exit Sub
    
12.    Set d = CreateObject("scripting.dictionary")
    
13.    If Not Intersect(Target, [j3:m70]) Is Nothing Then
    
14.      arr = Sheet5.Range("c3:f" & Sheet5.[c65536].End(3).Row)
    
15.      For i = 1 To UBound(arr)
    
16.         x = arr(i, 1)
    
17.         If Len(x) Then
    
18.           If InStr(d(x) & ",", "," & arr(i, Target.Column - 9) & ",") = 0 Then d(x) = d(x) & "," & arr(i, Target.Column - 9)
    
19.         End If
    
20.      Next
    
21.      TheList = IIf(Target.Column = 10, Join(d.keys, ","), Mid(d(Cells(Target.Row, 10).Value), 2))
    
22.    End If
    
23.    If Not Intersect(Target, [b3:e70]) Is Nothing Then
    
24.      arr = Sheet2.Range("c3:f" & Sheet2.[c65536].End(3).Row)
    
25.      For i = 1 To UBound(arr)
    
26.         x = arr(i, 1)
    
27.         If Len(x) Then
    
28.           If InStr(d(x) & ",", "," & arr(i, Target.Column - 1) & ",") = 0 Then d(x) = d(x) & "," & arr(i, Target.Column - 1)
    
29.         End If
    
30.      Next
    
31.      TheList = IIf(Target.Column = 2, Join(d.keys, ","), Mid(d(Cells(Target.Row, 2).Value), 2))
    
32.    End If
    
33.    With Target.Validation
    
34.       .Delete
    
35.       If Len(TheList) Then .Add xlValidateList, , , TheList
    
36.    End With
    
37. End Sub

复制代码

跳转到最佳答案楼层

大灰狼1976

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.      If Target.Count > 1 Then Exit Sub
   
3.      If Intersect(Target, [b3:b70]) Is Nothing Or Intersect(Target, [j3:j70]) Is Nothing Then Exit Sub
   
4.      Target.Offset(, 1).Resize(, 4).Validation.Delete
   
5.      Target.Offset(, 1).Resize(, 4).ClearContents
   
6. End Sub
   
7. 
   
8. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
9.    Dim TheList As String, i&
   
10.    If Target.Count > 1 Then Exit Sub
    
11.    If Not Application.Intersect(Target, Range("A3:A500")) Is Nothing Then [a1] = Target: Exit Sub
    
12.    Set d = CreateObject("scripting.dictionary")
    
13.    If Not Intersect(Target, [j3:m70]) Is Nothing Then
    
14.      arr = Sheet5.Range("c3:f" & Sheet5.[c65536].End(3).Row)
    
15.      For i = 1 To UBound(arr)
    
16.         x = arr(i, 1)
    
17.         If Len(x) Then
    
18.           If InStr(d(x) & ",", "," & arr(i, Target.Column - 9) & ",") = 0 Then d(x) = d(x) & "," & arr(i, Target.Column - 9)
    
19.         End If
    
20.      Next
    
21.      TheList = IIf(Target.Column = 10, Join(d.keys, ","), Mid(d(Cells(Target.Row, 10).Value), 2))
    
22.    End If
    
23.    If Not Intersect(Target, [b3:e70]) Is Nothing Then
    
24.      arr = Sheet2.Range("c3:f" & Sheet2.[c65536].End(3).Row)
    
25.      For i = 1 To UBound(arr)
    
26.         x = arr(i, 1)
    
27.         If Len(x) Then
    
28.           If InStr(d(x) & ",", "," & arr(i, Target.Column - 1) & ",") = 0 Then d(x) = d(x) & "," & arr(i, Target.Column - 1)
    
29.         End If
    
30.      Next
    
31.      TheList = IIf(Target.Column = 2, Join(d.keys, ","), Mid(d(Cells(Target.Row, 2).Value), 2))
    
32.    End If
    
33.    With Target.Validation
    
34.       .Delete
    
35.       If Len(TheList) Then .Add xlValidateList, , , TheList
    
36.    End With
    
37. End Sub

复制代码

idnoidno

正主自己出手最快

大灰狼1976

都没有附件，瞎蒙的！

cpl275538

大灰狼1976 发表于 2017-7-18 17:05
都没有附件，瞎蒙的！

您这强大的知识可不是蒙出来，没有附件您合并好，还是能完美运行，这就是您的实力，小辈望尘莫及啊

大灰狼1976

cpl275538 发表于 2017-7-18 17:11
您这强大的知识可不是蒙出来，没有附件您合并好，还是能完美运行，这就是您的实力，小辈望尘莫及啊

谢谢了，不要过分吹捧啊，我这人就一毛病，一夸就上天！