请各位老师帮忙

gwjkkkkk

Sub test()
Dim ar, br, vResult, i&, xNum&, dic As Object, vKey, isFlag As Boolean

    Application.ScreenUpdating = False
   
    ar = [A1].CurrentRegion.Value
    ReDim vResult(1 To UBound(ar), 0): vResult(1, 0) = "RESULT"
    ReDim br(1 To UBound(ar))
   
    Set dic = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(ar)
        If Len(ar(i, 1)) Then
            br(i) = Split(ar(i, 1), ",")
            xNum = Int((UBound(br(i)) + 1) * Rnd)
            vResult(i, 0) = br(i)(xNum)
            dic(vResult(i, 0)) = dic(vResult(i, 0)) + 1
        End If
    Next i
   
    isFlag = True
    For Each vKey In dic.keys
        If dic(vKey) > 50 Then isFlag = False: Exit For
    Next
   
    Do Until isFlag = True
        For i = 2 To UBound(vResult)
            If Len(vResult(i, 0)) Then
                If dic(vResult(i, 0)) > 50 Then
                    xNum = Int((UBound(br(i)) + 1) * Rnd())
                    dic(vResult(i, 0)) = dic(vResult(i, 0)) - 1
                    dic(br(i)(xNum)) = dic(br(i)(xNum)) + 1
                    vResult(i, 0) = br(i)(xNum)
                    isFlag = True
                    For Each vKey In dic.keys
                        If dic(vKey) > 50 Then isFlag = False: Exit For
                    Next
                    If isFlag = True Then Exit Do
                End If
            End If
        Next i
    Loop
   
    [T1].Resize(UBound(vResult)) = vResult
    [W1].Resize(dic.Count, 2) = Application.Transpose(Array(dic.keys, dic.items))
    Set dic = Nothing
    Application.ScreenUpdating = True
End Sub

gwjkkkkk

请参考附件。。。

fnjpn

gwjkkkkk 发表于 2024-9-11 19:44
请参考附件。。。

谢谢老师帮助

kyxfyzg

看看符合要求吗？

笨鸟飞不高

yynrzwh 发表于 2024-9-11 09:56
改一下

老师，用你的代码测试了一下，结果好象有问题！！

fnjpn

kyxfyzg 发表于 2024-9-12 10:03
看看符合要求吗？

老师你好，这个与要求不符

yynrzwh

d(t(x))=d(imin)+1
改为d(imin)=d(imin)+1

d(t(x))=d(t(0))+1
改为d(t(0))=d(t(0))+1

刀彐犬句

看不懂，不知道T列做什么用，最后实现的目的是什么

kyxfyzg

修改了一下，看看符合要求不

fnjpn

kyxfyzg 发表于 2024-9-12 15:40
修改了一下，看看符合要求不

谢谢老师，有几个仍然超过50了