如何找到大于或等于连续3个负数对应日期及具体的负数个数

Anny2021

试了很久，不能用函数解决问题，需要用VBA 找到Gap那行，连续负数大于或等于3个对应的起初日期及后面连续负数的个数，需要找到第一，二，三个，.见附件例子.谢谢各位

ykcbf1100

嗯，我来过这里了。

笨鸟飞不高

sample0414.zip (20.78 KB, 下载次数: 7)

2023-4-14 15:17 上传

点击文件名下载附件

Anny2021

笨鸟飞不高 发表于 2023-4-14 14:52

下载了文件出错，代码没有了，能告诉我怎样操作

笨鸟飞不高

Anny2021 发表于 2023-4-14 16:32
下载了文件出错，代码没有了，能告诉我怎样操作

Sub AwTest()
    Dim i&, j%, eRow&, eCol%, n%, y%, c%, arr
    eRow = Cells(Rows.Count, "I").End(3).Row
    eCol = Cells(2, Columns.Count).End(1).Column
    arr = Range([I2], Cells(eRow, eCol))
    ReDim brr(1 To UBound(arr) - 1, 1 To 6)
    For i = 2 To UBound(arr)
        If InStr(arr(i, 1), "Gap") Then
            n = 0: y = 0
            For j = 2 To UBound(arr, 2)
                If arr(i, j) < 0 Then
                    n = n + 1
                    If j = UBound(arr, 2) Then GoTo 100:
                Else
100:
                    If n >= 3 Then
                        y = y + 1: c = 2 * y - 1
                        If j = UBound(arr, 2) Then
                            brr(i - 1, c) = Format(arr(1, j - n + 1), "d-mmmm")
                        Else
                            brr(i - 1, c) = Format(arr(1, j - n), "d-mmmm")
                        End If
                        brr(i - 1, c + 1) = n
                    End If
                    n = 0
                End If
                If y = 3 Then Exit For
            Next
        End If
    Next
    [B3].Resize(UBound(brr), 6) = brr
End Sub

没遇到过这种情况！！

chxw68

感觉写啰索了。

准提部林

連續3次負數...取3組//

Sub TEST_A1()
Dim Arr, Brr, D$, R&, C%, i&, j%, k%
Arr = Range(Sheet1.[a1], Sheet1.UsedRange)
ReDim Brr(1 To UBound(Arr) - 2, 1 To 8)
For i = 3 To UBound(Arr)
    C = 0: k = 0: R = i - 2
    If InStr(Arr(i, 9), "Gap") = 0 Then GoTo i01
    For j = 10 To UBound(Arr, 2)
        If Arr(i, j) < 0 Then k = k + 1 Else k = 0
        If k = 1 Then D = Arr(2, j)
        If k = 3 Then C = C + 2: Brr(R, C - 1) = D
        If k >= 3 Then Brr(R, C) = k
        If C > 6 Then Exit For
    Next j
i01: Next i
[b3].Resize(UBound(Brr), 6) = Brr
End Sub

半百

Sub test()
r = Cells(Rows.Count, 8).End(3).Row
c = Cells(2, Columns.Count).End(1).Column
arr = Range("b2", Cells(r, c))
For i = 2 To UBound(arr)
    m = 0
    s = 0
    n = 0
    For j = 9 To UBound(arr, 2)
        If arr(i, j) < 0 Then
            If s = 0 Then s = arr(1, j)
            n = n + 1
        Else
            If n > 2 Then
                m = m + 1
                arr(i, m * 2 - 1) = s
                arr(i, m * 2) = n
            If m = 3 Then Exit For
            End If
            s = 0
            n = 0
        End If
    Next
Next
Range("b2", Cells(r, c)) = arr
End Sub