求个代码

wenping998

quqiyuan 发表于 2025-1-17 14:56
修改一下，仅供参考。。。

大哥 现在遇到问题了 就是算31 13 41 14组合都没问题呢 但是要是算01 02 03 04 05 06组合就不行了 看能给解决下吗

quqiyuan

wenping998 发表于 2025-4-2 16:46
大哥 现在遇到问题了 就是算31 13 41 14组合都没问题呢 但是要是算01 02 03 04 05 06组合就不行了 看能给 ...

你把文件发上来，还有问题所在说一下，这么久了，我需要重新看看。。。

wenping998

quqiyuan 发表于 2025-4-2 17:22
你把文件发上来，还有问题所在说一下，这么久了，我需要重新看看。。。

就是这个  0 1 2 3 4 5 6  这7个数字 每2个都可以组合 其他的没问题 就是01 02 03 04 05 06的组合就算不出来了

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
        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 Len(arr(i + 1, j)) > 0 Then
                    x = Application.Max(x, i + 1)
                    Exit For
                End If
            Next
            If Len(arr(i, 3 + s1)) > 0 And Len(arr(i + 1, 3 + s2)) > 0 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