求助：N列内找出连续有出现的标红，N可自由调整值。

szzds01

N列内找出连续有出现的标红，N可自由调整值。
   （如：中国铝业、粤宏远A，连续3列有出现，铜陵有色连续4列有出现）

谢谢先。

111.rar (11.18 KB, 下载次数: 13)

2022-12-15 21:19 上传

点击文件名下载附件

汉唐

请见附件。。。。

陆离Lowry

没看懂，中国铝业第五列不是也有吗？

liulang0808

Sub 按钮1_Click()
    n = 4
    Set Rng = Nothing
    Set d = CreateObject("scripting.dictionary")
    arr = [a1].CurrentRegion
    For i = 1 To UBound(arr, 2)
        For j = 1 To UBound(arr)
            d(arr(j, i)) = d(arr(j, i)) & "," & Cells(j, i).Address(0, 0)
        Next j
    Next i
    For Each k In d.keys
        brr = Split(d(k), ",")
        If UBound(brr) >= n Then
            Set rngx = Nothing
            w = get_ok(brr, n, rngx)
            If get_ok(brr, n, rngx) Then
                If Rng Is Nothing Then
                    Set Rng = rngx
                Else
                    Set Rng = Union(Rng, rngx)
                End If
            End If
        End If
    Next k
    If Not Rng Is Nothing Then
        Rng.Font.ColorIndex = 3
    End If
End Sub
Function get_ok(brr, n, rngx)
    get_ok = False
    x = 1
    y = Range(brr(1)).Column
    Set rngx = Range(brr(1))
    For j = 2 To UBound(brr)
        If Range(brr(j)).Column - y <> 1 Then
            If x >= 4 Then
                get_ok = True
                Exit Function
            Else
                x = 1
                y = Range(brr(j)).Column
                Set rngx = rngx
            End If
        Else
            x = x + 1
            y = Range(brr(j)).Column
            Set rngx = Union(rngx, Range(brr(j)))
        End If
    Next j
    If x >= 4 Then get_ok = True
End Function

liulang0808

附件内容供参考。。。。。。。

szzds01

汉唐 发表于 2022-12-16 08:38
请见附件。。。。

你好，我的目标不是仅仅找出标红的股票，是先要在N列内找出连续有出现的股票，然后标红，N可自由调整值。可否再帮忙看一下，谢谢。

szzds01

liulang0808 发表于 2022-12-16 09:00
附件内容供参考。。。。。。。

老师好，请问我要改参数为3，是否在标红处（3个地方）修改就可以了？
Sub 按钮1_Click()
    n = 4
    Set Rng = Nothing
    Set d = CreateObject("scripting.dictionary")
    arr = [a1].CurrentRegion
    For i = 1 To UBound(arr, 2)
        For j = 1 To UBound(arr)
            d(arr(j, i)) = d(arr(j, i)) & "," & Cells(j, i).Address(0, 0)
        Next j
    Next i
    For Each k In d.keys
        brr = Split(d(k), ",")
        If UBound(brr) >= n Then
            Set rngx = Nothing
            w = get_ok(brr, n, rngx)
            If get_ok(brr, n, rngx) Then
                If Rng Is Nothing Then
                    Set Rng = rngx
                Else
                    Set Rng = Union(Rng, rngx)
                End If
            End If
        End If
    Next k
    If Not Rng Is Nothing Then
        Rng.Font.ColorIndex = 3
    End If
End Sub
Function get_ok(brr, n, rngx)
    get_ok = False
    x = 1
    y = Range(brr(1)).Column
    Set rngx = Range(brr(1))
    For j = 2 To UBound(brr)
        If Range(brr(j)).Column - y <> 1 Then
            If x >= 4 Then
                get_ok = True
                Exit Function
            Else
                x = 1
                y = Range(brr(j)).Column
                Set rngx = rngx
            End If
        Else
            x = x + 1
            y = Range(brr(j)).Column
            Set rngx = Union(rngx, Range(brr(j)))
        End If
    Next j
    If x >= 4 Then get_ok = True
End Function