10个元素任意取N个

天地一相

感谢帮助！详见截图附件

时间的音符

Private Function getBitOne(num)
    n = num: ret = 0
    Do While n <> 0
        ret = ret + 1
        n = n - (n And -n)
    Loop
    getBitOne = ret
End Function

Private Function bitToNum(num)
    ret = ""
    For i = 0 To 9
        If (num And (2 ^ i)) <> 0 Then
            ret = ret & i
        End If
    Next
    bitToNum = ret
End Function

Public Sub main()
    Dim colls(0 To 10) As Collection
    For i = 0 To 10
        Set colls(i) = New Collection
    Next
    For i = 0 To (2 ^ 10) - 1
        n = getBitOne(i)
        colls(n).Add bitToNum(i)
    Next
   
    arr = [b3:b6]
    c = 4
    For Each a In arr
        r = 3
        For Each Item In colls(a)
            Cells(r, c) = Item
            r = r + 1
        Next
        c = c + 1
    Next
End Sub

gwjkkkkk

Option Explicit
Sub test()
    Dim i&, ar, dr(), er(), vResult(), t#
   
    ReDim dr(1 To 10)
    For i = 1 To UBound(dr)
        dr(i) = i - 1
    Next i
   
    ar = Range("B3", Cells(Rows.Count, "B").End(xlUp)).Value
   
    With Range("D3:XFD" & Rows.Count)
        .Clear
        .NumberFormatLocal = "@"
    End With
    For i = 1 To UBound(ar)
        ReDim er(1 To ar(i, 1))
        ReDim vResult(1 To WorksheetFunction.Combin(UBound(dr), ar(i, 1)), 0)
        combinArr dr, er, vResult, ar(i, 1), 0
        Cells(3, i + 3).Resize(UBound(vResult)) = vResult
    Next i
   
    Beep
End Sub
  
Function combinArr(ByRef ar(), ByRef br(), ByRef cr(), ByVal n&, Optional _
    ByRef iGroup&, Optional ByVal iStart&, Optional ByVal iNum& = 1)
    Dim i&, j&
    For i = iStart + 1 To UBound(ar) - n + iNum
        If iNum < n Then
           br(iNum) = ar(i)
           Call combinArr(ar, br, cr, n, iGroup, i, iNum + 1)
        Else
           br(iNum) = ar(i)
           iGroup = iGroup + 1
           cr(iGroup, 0) = Join(br, "")
        End If
    Next
End Function

gwjkkkkk

参与一下。。。

yjh_27

1. Sub aa()
   
2. arr = [b3:b6]   '数据源
   
3. For i = 1 To UBound(arr)
   
4. brr = ArrCP0(10, arr(i, 1), 41, 0, 1)
   
5. Range("h3").Resize(UBound(brr), 1).Offset(0, i - 1) = brr '输出
   
6. Next
   
7. End Sub
   

复制代码

arrCP0 见


n取m 自定义函数 随机 组合 排列 分组 分配
https://club.excelhome.net/thread-1526867-1-1.html
(出处: ExcelHome技术论坛)

天地一相

yjh_27 发表于 2024-5-19 13:44
arrCP0 见

谢谢，太牛了！