一个变通使用代码的问题

weide_yang

想要用老师的以下代码自己变通解决附件中的问题，始终未成功，特请高手帮助，谢谢！
Sub test()
    Dim rng As Range, arr, i&, tmp$
    Range("d3:d" & Cells(Rows.Count, 4).End(3).Row).Select
    arr = Range("d3:d" & Cells(Rows.Count, 4).End(3).Row)
    If ActiveCell.Column <> "4" Then Exit Sub
    tmp = ActiveCell.Value
    For i = 1 To UBound(arr)
        If arr(i, 1) = tmp Then
            If rng Is Nothing Then
                Set rng = Cells(i + 1, "f")
            Else
                Set rng = Union(Cells(i + 1, "f"), rng)
            End If
        End If
    Next
    If Not rng Is Nothing Then rng.Select
End Sub

weide_yang

不好意思，更正一下：原来老师给出的代码如下：

Sub test()
    Dim rng As Range, arr, i&, tmp$
    arr = Range("d2:d" & Cells(Rows.Count, 4).End(3).Row)
    If ActiveCell.Column <> "4" Then Exit Sub
    tmp = ActiveCell.Value
    For i = 1 To UBound(arr)
        If arr(i, 1) = tmp Then
            If rng Is Nothing Then
                Set rng = Cells(i + 1, "f")
            Else
                Set rng = Union(Cells(i + 1, "f"), rng)
            End If
        End If
    Next
    If Not rng Is Nothing Then rng.Select
End Sub

weide_yang

更正一下，原可供参考的代码如下：
Sub test()
    Dim rng As Range, arr, i&, tmp$
    arr = Range("d2:d" & Cells(Rows.Count, 4).End(3).Row)
    If ActiveCell.Column <> "4" Then Exit Sub
    tmp = ActiveCell.Value
    For i = 1 To UBound(arr)
        If arr(i, 1) = tmp Then
            If rng Is Nothing Then
                Set rng = Cells(i + 1, "f")
            Else
                Set rng = Union(Cells(i + 1, "f"), rng)
            End If
        End If
    Next
    If Not rng Is Nothing Then rng.Select
End Sub

ykcbf1100

还是新写一个吧。

ykcbf1100

参与一下。。。

1. Sub test()  '//2024.3.24
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     r = Cells(Rows.Count, 4).End(3).Row
   
4.     For i = 3 To r
   
5.         s = Cells(i, 4)
   
6.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
   
7.         d(s)(i) = i
   
8.     Next
   
9.     tmp = ActiveCell.Value
   
10.     On Error Resume Next
    
11.     For i = 3 To r
    
12.         For Each k In d.keys
    
13.             If tmp = k Then
    
14.                 Set rng = Nothing
    
15.                 Range("f3:f1000").Interior.ColorIndex = 0
    
16.                 For Each kk In d(k).keys
    
17.                     If rng Is Nothing Then
    
18.                         Set rng = Cells(kk, "f")
    
19.                     Else
    
20.                         Set rng = Union(Cells(kk, "f"), rng)
    
21.                     End If
    
22.                 Next
    
23.             End If
    
24.         Next
    
25.     Next
    
26.     If Not rng Is Nothing Then rng.Select
    
27.     rng.Cells.Interior.ColorIndex = 8
    
28. End Sub
    

复制代码

weide_yang

非常感谢ykcbf1100老师帮助！就是这样的效果。向您学习了！

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, i&, rng As Range, vTemp, selRng As Range
    Set rng = Range("D3", Cells(Rows.Count, "D").End(xlUp))
    If Intersect(ActiveCell, rng) Is Nothing Then Exit Sub
    With rng
        ar = .Value: vTemp = ActiveCell.Value
        For i = 1 To UBound(ar)
            If ar(i, 1) = vTemp Then
                If selRng Is Nothing Then
                    Set selRng = .Cells(i, 1).Offset(, 2)
                Else
                    Set selRng = Union(selRng, .Cells(i, 1).Offset(, 2))
                End If
            End If
        Next i
    End With
    If Not selRng Is Nothing Then selRng.Select
End Sub

gwjkkkkk

请参考附件。。。

lizhipei78

不是直接筛选就可以看到相对应的数据了么，干嘛搞这么复杂

NBCBA123

1. Sub test()
   
2. If Selection.Column <> 4 Then Exit Sub
   
3. Set dic = CreateObject("scripting.dictionary")
   
4. Columns("f").Interior.ColorIndex = xlNone
   
5. lstrw = Cells(Rows.Count, 4).End(xlUp).Row
   
6. arr = Range("d3:d" & lstrw)
   
7. For a = 3 To lstrw
   
8.     dic(arr(a - 2, 1)) = dic(arr(a - 2, 1)) & " f" & a
   
9. Next a
   
10. For Each Rng In Selection
    
11.     If dic.exists(Rng.Value) Then
    
12.         k = Split(Trim(dic(Rng.Value)))
    
13.     For Each rng1 In k
    
14.         Range(rng1).Interior.ColorIndex = 6
    
15.     Next rng1
    
16.     End If
    
17. Next Rng
    
18. Set dic = Nothing
    
19. End Sub

复制代码