参数1~5随机抽取组合

mjgw

笨鸟飞不高

micch

1. Option Explicit
   
2. Option Base 1
   
3. Option Compare Text
   
4. 
   
5. Dim d As Dictionary
   
6. Dim ar
   
7. 
   
8. Sub Test()
   
9.     Dim br, cr
   
10.     Dim i%, j%, k%, r%
    
11.    
    
12.     '读取数据到数组
    
13.     ReDim ar(1 To 5)
    
14.     For j = 1 To 5
    
15.         r = Columns(j).Find("*", , -4163, 1, 1, 2).Row
    
16.         br = Cells(2, j).Resize(r - 1).Value
    
17.         ar(j) = Application.Transpose(br)
    
18.     Next
    
19.     '字典存储结果，直接去重
    
20.     Set d = New Dictionary
    
21.     While d.Count < 1000
    
22.         DFS 1, ""
    
23.     Wend
    
24.     '输出
    
25.     Range("h1:h1000").Value = Application.Transpose(d.Keys)
    
26. End Sub
    
27. Private Sub DFS(k, s)
    
28.     Dim x
    
29.     x = GetRand(ar(k))
    
30.     If k >= 5 Then
    
31.         d(Mid(s & "-" & x, 2)) = ""
    
32.         Exit Sub
    
33.     Else
    
34.         DFS k + 1, s & "-" & x
    
35.     End If
    
36. End Sub
    
37. Function GetRand(ar0)
    
38.     Dim j%
    
39.     Randomize
    
40.     j = UBound(ar0)
    
41.     GetRand = ar0(Int(Rnd * j) + 1)
    
42. End Function
    

复制代码

micch

mjgw

谢谢，但我加入代码，怎么不执行呀？能不能加一个按钮。

gwjkkkkk

Option Explicit
Sub test1()
    Dim cr, dr, er(), i&, m&, n&
   
    With Intersect([A1].CurrentRegion, Columns("A:E"))
        cr = Intersect(.Offset(), .Offset(1)).Value
    End With
    m = UBound(cr): n = UBound(cr, 2)
    ReDim dr(1 To n)
   
    Call cartesianProductDG1(cr, dr, er)

    [H1].CurrentRegion.Clear
    ReDim cr(1 To UBound(er), 0)
    For i = 1 To UBound(er)
        cr(i, 0) = er(i)
    Next i
   
    With [H1].Resize(UBound(cr))
         .Value = cr
        .EntireColumn.AutoFit
    End With
End Sub
Function cartesianProductDG1(ByVal ar, ByVal br, ByRef vResult, _
    Optional ByRef iGroup&, Optional ByVal n& = 1)
    Dim i&, j&
    For i = 1 To UBound(ar)
        If Len(ar(i, n)) Then
            br(n) = ar(i, n)
            If n = UBound(ar, 2) Then
                iGroup = iGroup + 1
                ReDim Preserve vResult(1 To iGroup)
                vResult(iGroup) = Join(br, "-")
            Else
                cartesianProductDG1 ar, br, vResult, iGroup, n + 1
            End If
        End If
    Next
End Function

gwjkkkkk

参与一下。。。

一招秒杀

1句6行，还有更简单的吗

grf1973

和二楼思路一样，不考虑去重。

usedrange

参与一下

1. Sub t()
   
2.     Dim arr, brr, i%, r%, n%, k%
   
3.     arr = Sheet1.[a1:e10]
   
4.     n = 1
   
5.     ReDim brr(1 To 1000, 1 To 1)
   
6.     Do While n < 1001
   
7.         For i = 1 To 5
   
8.             k = Sheet1.Cells(1, i).End(4).Row
   
9.             r = WorksheetFunction.RandBetween(2, k)
   
10.             brr(n, 1) = brr(n, 1) & arr(r, i) & "-"
    
11.         Next i
    
12.         brr(n, 1) = Mid(brr(n, 1), 1, Len(brr(n, 1)) - 1)
    
13.         n = n + 1
    
14.     Loop
    
15.     Sheet1.[f2].Resize(UBound(brr), 1) = brr
    
16. End Sub

复制代码