请大师改下VBA只提取9位数的结果

阿力力

问题已解决，谢谢gwjkkkkk大师！同时也感谢回复的几个大师。
gwjkkkkk大师写的代码：

Option Explicit
Sub TEST2()
    Dim ar, br, cr, i&, j&, k&, r&, n&

    Application.ScreenUpdating = False

    ar = Range("B38", Cells(Rows.Count, "g").End(xlUp)).Value
    br = Range("H38", Cells(Rows.Count, "J").End(xlUp)).Value
    ReDim cr(1 To UBound(ar) * UBound(br), 1 To UBound(ar, 2) + UBound(br, 2))
   
    For i = 1 To UBound(ar)
        For k = 1 To UBound(br)
            r = r + 1: n = 0
            For j = 1 To UBound(ar, 2)
                n = n + 1
                cr(r, n) = ar(i, j)
            Next j
            For j = 1 To UBound(br, 2)
                n = n + 1
                cr(r, n) = br(k, j)
            Next j
        Next k
    Next i
   
    Range("BB2").Resize(UBound(cr), UBound(cr, 2)) = cr
   
    Application.ScreenUpdating = True
    Beep
End Sub

蓝桥玄霜

九位的例子：

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br(), i&, j&, r&

    Application.ScreenUpdating = False

    With [B38].CurrentRegion
        ar = .Value
        For j = 1 To UBound(ar, 2) Step 3
            r = r + 1
            ReDim Preserve br(1 To r)
            br(r) = Range(.Cells(1, (r - 1) * 3 + 1), .Cells(.Rows.Count + 1, (r - 1) * 3 + 3).End(xlUp)).Value
        Next j
    End With
    ar = cartesianProduct2(br)
   
    Range("BB2").CurrentRegion.Clear
    Range("BB2").Resize(UBound(ar), UBound(ar, 2)) = ar
   
    Application.ScreenUpdating = True
    Beep
End Sub
Function cartesianProduct2(ByVal ar) As Variant
    Dim br&(), vResult(), iGroup&, i&, j&, m&, n&, x&
   
    n = UBound(ar): iGroup = 1
    For i = 1 To UBound(ar)
         m = m + UBound(ar(i), 2)
         iGroup = iGroup * UBound(ar(i))
    Next i
    ReDim br(1 To n)
    ReDim vResult(1 To iGroup, 1 To m)
    For j = 1 To n: br(j) = 1: Next

    iGroup = 0
    Do
        iGroup = iGroup + 1
        x = 0
        For j = 1 To n
            For i = 1 To UBound(ar(j), 2)
                x = x + 1
                vResult(iGroup, x) = ar(j)(br(j), i)
            Next i
        Next
        
        For j = n To 1 Step -1
            br(j) = br(j) + 1
            If br(j) <= UBound(ar(j)) Then Exit For Else br(j) = 1
        Next
    Loop Until j = 0
   
    cartesianProduct2 = vResult
End Function

gwjkkkkk

参与一下。。。

LIUZHU

慢看懂什么意思

约定的童话

这算法概率应该不高吧，先出拳的石头剪刀布赢不了的

阿力力

gwjkkkkk 发表于 2024-6-1 12:37
参与一下。。。

谢谢大师，只是您的VBA排列的结果太多了。原结果是前6位共16行与后面的3位两行排列，共32个9位数结果。

阿力力

LIUZHU 发表于 2024-6-1 12:59
慢看懂什么意思

大师，用前边的16行6位数与后边的两行或多行的3位数排列，后面2行就是32种结果，4行就是64种结果

阿力力

蓝桥玄霜 发表于 2024-6-1 12:22
九位的例子：

蓝桥版主，您好，结果少了14注。
Sub 组成9位数()
Dim ar, br(), m&, i&, x%
ar = Range("j38").CurrentRegion
For i = 1 To UBound(ar)
If Len(ar(i, 3)) Then
m = m + 1
ReDim Preserve br(1 To 9, 1 To m)
For x = 1 To 6
br(x, m) = ar(i, x)
If ar(i, x + 3) <> "" Then
br(x + 3, m) = ar(i, x + 3)
Else
m = m - 1: Exit For
End If
Next
End If
Next
[aq:ay].ClearContents
If m > 65536 Then MsgBox "超过 65536注 ！": End
[aq2].Resize(m, 9) = Application.Transpose(br)
End Sub

LIUZHU

阿力力 发表于 2024-6-1 14:53
大师，用前边的16行6位数与后边的两行或多行的3位数排列，后面2行就是32种结果，4行就是64种结果

是连接在一起，不是组合吧？