vba怎么实现在指定条件下3列随机组合

grf1973

参与一下。。。。。

gwjkkkkk

dong130 发表于 2024-9-10 19:39
哈哈，感谢感谢，可能大神理解错了，就是比如sheet1中A列分类为a或c时，组合时只能在sheet2中A列分类中也 ...

Option Explicit
Sub TEST2()
    Dim ar, br, cr, dr, i&, j&, xNum&, dic As Object, vKey
   
    Application.ScreenUpdating = False
   
    Set dic = CreateObject("Scripting.Dictionary")
    cr = Worksheets(2).[A1].CurrentRegion.Value
    For i = 2 To UBound(cr)
        If Not dic.exists(cr(i, 1)) Then
            Set dic(cr(i, 1)) = CreateObject("Scripting.Dictionary")
        End If
        dic(cr(i, 1))(cr(i, 2)) = cr(i, 3)
    Next i
   
    For Each vKey In dic.keys
        If dic(vKey).Count > 1 Then
            br = Application.Transpose(Array(dic(vKey).keys, dic(vKey).items))
        Else
            ReDim br(1 To 1, 1 To 2)
            br(1, 1) = dic(vKey).keys()(0): br(1, 2) = dic(vKey).items()(0)
        End If
        dic(vKey) = br
    Next
   
    ar = [A1].CurrentRegion.Value
    ReDim br(1 To UBound(ar), 0)
    br(1, 0) = "组合A+B+C"
   
    For i = 2 To UBound(ar)
        ReDim dr(1 To 3)
        cr = dic(ar(i, 1))
        For j = 1 To 2
            xNum = Int(UBound(cr) * Rnd + 1)
            If j = 2 Then dr(3) = cr(xNum, j) Else dr(j) = cr(xNum, j)
        Next j
        dr(2) = ar(i, 3)
        br(i, 0) = Trim(Join(dr))
    Next i
        
    [E1].CurrentRegion.Clear
    [E1].Resize(UBound(br)) = br
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

dong130 发表于 2024-9-10 19:39
哈哈，感谢感谢，可能大神理解错了，就是比如sheet1中A列分类为a或c时，组合时只能在sheet2中A列分类中也 ...

....................