满足条件的一段数字记录在对应区域代码如何写

cys888

爱疯

Sub test()
    Dim A, B, j, c, jStart, jEnd, length, maxLength, ans

    Rows(3) = ""
    A = [e2:bn4]    '左右多选1列
    c = UBound(A, 2)
    A(3, 1) = "^"
    A(3, c) = "$"
    jStart = 2
    jEnd = jStart
    maxLength = -1


    For j = 2 To c
        If Len(A(3, j)) > 0 Then
            jEnd = j - 1
            length = jEnd - jStart + 1
            If maxLength <= length Then
                If maxLength < length Then ans = "": maxLength = length
                ans = ans & ";" & jStart & "," & jEnd
            End If
            jStart = j + 1
        End If
    Next


    B = VBA.Split(ans, ";")
    For i = 1 To UBound(B)
        For j = Split(B(i), ",")(0) To Split(B(i), ",")(1)
            A(2, j) = A(1, j)
        Next
    Next
    A(3, 1) = ""
    A(3, c) = ""
    [e2].Resize(UBound(A), UBound(A, 2)) = A
End Sub

lightsnow

Sub model()
Dim imax!, s!, length!, c!, flag! 's起始位，len长度，c过程变量用以表示列
Dim arr(1 To 5, 1 To 2) '第1列存放长度，第2列存放起始位置
Dim NextOne As Boolean
NextOne = False
c = 6
flag = 0
s = 6
imax = 0
Do  'step1：装载数据
    If Cells(4, c) = Empty Then
        i = i + 1
        length = length + 1
        NextOne = True
        If c = 65 Then
            flag = flag + 1
            arr(flag, 1) = length
            arr(flag, 2) = s
            If length > imax Then imax = length
        End If

    Else
        If NextOne Then
            flag = flag + 1
            arr(flag, 1) = length
            arr(flag, 2) = s
            s = s + length
            If length > imax Then imax = length
            length = 0
        End If
        NextOne = False
        s = s + 1
    End If
    c = c + 1
Loop Until c = 66

'step2：清空现有数据
Range(Cells(3, 6), Cells(3, 65)).ClearContents

'step3：提取数据
For c = 1 To 5
    If arr(c, 1) = imax Then
        Cells(2, arr(c, 2)).Resize(1, imax).Copy Cells(3, arr(c, 2))
    End If
Next c
End Sub

cys888

lightsnow 发表于 2020-7-21 10:24
Sub model()
Dim imax!, s!, length!, c!, flag! 's起始位，len长度，c过程变量用以表示列
Dim arr(1 To  ...

非常感谢

cys888

爱疯 发表于 2020-7-21 11:58
Sub test()
    Dim A, B, j, c, jStart, jEnd, length, maxLength, ans

非常感谢