10个元素任意取N个

天地一相

感谢帮助！详见截图附件

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 见

谢谢，太牛了！