返回一天内连续7次以上大于或等于80的日期

zzs2060

如题，需要返回同一天内E列数据连续出现7次及以上大于或等于80和100的日期。求助各位大神。谢谢！

liulang0808

Sub 按钮1_Click()
    arr = [a1].CurrentRegion.Offset(1)
    r = 1
    For j = 1 To UBound(arr) - 1
        If Val(arr(j, 5)) >= 80 Then
            sm = 1
            dt = arr(j, 2)
            For i = j + 1 To UBound(arr)
                If arr(j, 2) = dt And Val(arr(i, 5)) >= 80 Then
                    sm = sm + 1
                Else
                    j = i - 1
                    If sm > 7 Then
                        r = r + 1
                        Cells(r, "r") = dt
                    End If
                    Exit For
                End If
            Next i
        End If
    Next j
End Sub

liulang0808

供参考。。。。。。

gwjkkkkk

Option Explicit
Sub test1()
    Dim ar, br, i&, j&, p&, n&, r&, iPosCol&

    With [A1].CurrentRegion
        p = 2: iPosCol = 5
        ar = .Resize(.Rows.Count + 1)
        ReDim br(1 To UBound(ar), 0)
        For i = 2 To UBound(ar) - 1
            If ar(i + 1, 2) <> ar(p, 2) Then
                n = 0
                For j = p To i
                    If Val(ar(j, iPosCol)) > 80 Then n = n + 1
                Next j
                If n >= 7 Then r = r + 1: br(r, 0) = ar(p, 2)
                p = i + 1
            End If
        Next i
        
        Columns("Q").Clear
        With [Q2].Resize(r)
            .Value = br
            .NumberFormatLocal = "yyyy-m-d"
        End With
    End With
End Sub

gwjkkkkk

请参考。。。

cnmlgb9998

PQ解决！！！！！！！！！！！！！！！！！！

今铭昔

zzs2060

liulang0808 发表于 2024-3-27 07:19
供参考。。。。。。

谢谢大神！现在需要将符合条件的日期单元格填充为黄色，需要添加说明代码，谢谢。

zzs2060

liulang0808 发表于 2024-3-27 07:18
Sub 按钮1_Click()
    arr = [a1].CurrentRegion.Offset(1)
    r = 1

谢谢大神！现在需要将符合条件的日期单元格填充为黄色，需要添加说明代码，谢谢。

liulang0808

Sub 按钮1_Click()
    arr = [a1].CurrentRegion.Offset(1)
    r = 1
    Application.ScreenUpdating = False
    For j = 1 To UBound(arr) - 1
        If Val(arr(j, 5)) >= 80 Then
            sm = 1
            dt = arr(j, 2)
            For i = j + 1 To UBound(arr)
                If arr(j, 2) = dt And Val(arr(i, 5)) >= 80 Then
                    sm = sm + 1
                Else
                    If sm > 7 Then
                        r = r + 1
                        Cells(r, "r") = dt
                        Range(Cells(j + 1, 2), Cells(i, 2)).Interior.ColorIndex = 6
                    End If
                    j = i - 1
                    Exit For
                End If
            Next i
        End If
    Next j
    Application.ScreenUpdating = True
End Sub