求个代码

quqiyuan

代码如下。。。
Sub test()
    Dim wb As Workbook, sht As Worksheet
    Set wb = ThisWorkbook
    Set sht = wb.Sheets("sheet1")
    r = sht.Cells(Rows.Count, 1).End(3).Row
    arr = sht.[a1].Resize(r, 8)
    s = sht.[n1]
    s1 = --Left(s, 1): s2 = --Right(s, 1)
    ReDim brr(1 To UBound(arr), 1)
    brr(1, 0) = 1
    n = 1
    For i = 2 To UBound(arr) - 1
        If arr(i, 3 + s1) <> Empty And arr(i + 1, 3 + s2) <> Empty Then
            n = n + 1
            brr(n, 0) = arr(i, 1)
            brr(n, 1) = brr(n, 0) - brr(n - 1, 0) - 1
        End If
    Next
    sht.[k1].CurrentRegion.Offset(1).ClearContents
    sht.[k2].Resize(n, 2) = brr
    Beep
End Sub

wenping998

quqiyuan 发表于 2025-1-15 16:56
代码如下。。。

太厉害了 感谢感谢 大哥

wenping998

quqiyuan 发表于 2025-1-15 16:56
参与一下，仅供参考。。。

大哥 这个代码怎么改 可以应用所有sheet啊  现在这个代码只对sheet1 有效 ，但是有4个sheet页。

quqiyuan

wenping998 发表于 2025-1-17 11:04
大哥 这个代码怎么改 可以应用所有sheet啊  现在这个代码只对sheet1 有效 ，但是有4个sheet页。

加个循环啊，for each sh in wb.sheets

quqiyuan

参与一下，仅供参考。。。

quqiyuan

代码如下。。。
Sub test()
    Dim wb As Workbook, sht As Worksheet
    Set wb = ThisWorkbook
'    Set sht = wb.Sheets("sheet1")
    For Each sht In wb.Sheets
        r = sht.Cells(Rows.Count, 1).End(3).Row
        arr = sht.[a1].Resize(r, 9)
        s = sht.[n1]
        s1 = --Left(s, 1): s2 = --Right(s, 1)
        ReDim brr(1 To UBound(arr), 1)
        brr(1, 0) = 1
        n = 1
        For i = 2 To UBound(arr) - 1
            If arr(i, 3 + s1) <> Empty And arr(i + 1, 3 + s2) <> Empty Then
                n = n + 1
                brr(n, 0) = arr(i, 1)
                brr(n, 1) = brr(n, 0) - brr(n - 1, 0) - 1
            End If
        Next
        sht.[k1].CurrentRegion.ClearContents
        sht.[k1:l1] = [{"序列","结果"}]
        sht.[k2].Resize(n, 2) = brr
    Next
    Beep
End Sub

wenping998

quqiyuan 发表于 2025-1-17 12:18
代码如下。。。
Sub test()
    Dim wb As Workbook, sht As Worksheet

大哥  所有sheet页里的A列数字都是按序列填充的，可以下拉，现在计算的结果如图所示，在sheet1中，最后一个31组合（7083行）的结果到C:I区域最后一个5的下一个空行（7094行） 之间的间隔10，也需要算出来。等7094行生成新的数字，就得计算空行7085行到上面31组合（7083行）之间的间隔，以此类推。这个用代码可以实现吗？4个sheet都需要，麻烦你了.

quqiyuan

wenping998 发表于 2025-1-17 14:19
大哥  所有sheet页里的A列数字都是按序列填充的，可以下拉，现在计算的结果如图所示，在sheet1中，最后一 ...

修改一下，仅供参考。。。

quqiyuan

代码如下。。。
Sub test()
    Dim wb As Workbook, sht As Worksheet
    Set wb = ThisWorkbook
'    Set sht = wb.Sheets("sheet1")
    For Each sht In wb.Sheets
        x = 0
        r = sht.Cells(Rows.Count, 1).End(3).Row
        arr = sht.[a1].Resize(r, 9)
        s = sht.[n1]
        s1 = --Left(s, 1): s2 = --Right(s, 1)
        ReDim brr(1 To UBound(arr), 1)
        brr(1, 0) = 1
        n = 1
        For i = 2 To UBound(arr) - 1
            For j = 3 To 9
                If arr(i + 1, j) <> Empty Then
                    x = Application.Max(x, i + 1)
                    Exit For
                End If
            Next
            If arr(i, 3 + s1) <> Empty And arr(i + 1, 3 + s2) <> Empty Then
                n = n + 1
                brr(n, 0) = arr(i, 1)
                brr(n, 1) = brr(n, 0) - brr(n - 1, 0) - 1
            End If
        Next
        n = n + 1
        If x + 1 > UBound(arr) Then
            brr(n, 0) = arr(x, 1) + 1
        Else
            brr(n, 0) = arr(x + 1, 1)
        End If
        brr(n, 1) = brr(n, 0) - brr(n - 1, 0) - 1
        sht.[k1].CurrentRegion.ClearContents
        sht.[k1:l1] = [{"序列","结果"}]
        sht.[k2].Resize(n, 2) = brr
    Next
    Beep
End Sub

wenping998

wenping998 发表于 2025-1-17 14:19
大哥  所有sheet页里的A列数字都是按序列填充的，可以下拉，现在计算的结果如图所示，在sheet1中，最后一 ...

还得是大哥厉害啦 膜拜中……