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

dong130

Sheet2中A列跟Sheet1中A列一样时，Sheet1中C列标题跟Sheet2中的B列和C列组合（在同一个分类下组合，不同分类组合不同分类下的数据）。组合方式：sheet2中的B列（前缀）+ 空格 + sheet1中C列标题 + 空格 + sheet2中的C列（后缀）
PS：sheet2中的B列（前缀）在同分类下随机选取，sheet2中的C列（后缀）也是在同分类下随机选取，然后跟标题组合，标题顺序不变，但是每个都要先用过后可以重复在用

sheet2中B列和C列的内容不一定都有，行数也不一定一样

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br, cr, dr, i&, j&, xNum&
   
    Application.ScreenUpdating = False
   
    cr = Worksheets(2).[A1].CurrentRegion.Value
    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)
        For j = 2 To 3
            xNum = Int((UBound(cr) - 1) * Rnd + 2)
            If j = 2 Then dr(1) = 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

gwjkkkkk 发表于 2024-9-10 19:06
...............................

哈哈，感谢感谢，可能大神理解错了，就是比如sheet1中A列分类为a或c时，组合时只能在sheet2中A列分类中也为a或c对应后面得值组合，不是sheet2中B列和C列中值任意组合

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr, crr(), drr
   
4.     Dim d As Object
   
5.     Randomize Timer
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     With Worksheets("sheet2")
   
8.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
9.         brr = .Range("a2:c" & r)
   
10.         For i = 1 To UBound(brr)
    
11.             If Not d.exists(brr(i, 1)) Then
    
12.                 Set d(brr(i, 1)) = CreateObject("scripting.dictionary")
    
13.             End If
    
14.             d(brr(i, 1))(i) = Empty
    
15.         Next
    
16.     End With
    
17.     With Worksheets("sheet1")
    
18.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
19.         arr = .Range("a2:c" & r)
    
20.         ReDim crr(1 To UBound(arr), 1 To 1)
    
21.         For i = 1 To UBound(arr)
    
22.             If d.exists(arr(i, 1)) Then
    
23.                 drr = d(arr(i, 1)).keys
    
24.                 x1 = Int(Rnd() * (UBound(drr) + 1))
    
25.                 x2 = Int(Rnd() * (UBound(drr) + 1))
    
26.                 If brr(drr(x1), 2) <> empyt Then
    
27.                     crr(i, 1) = brr(drr(x1), 2) & Space(1) & arr(i, 3)
    
28.                 Else
    
29.                     crr(i, 1) = arr(i, 3)
    
30.                 End If
    
31.                 If brr(drr(x2), 3) <> Empty Then
    
32.                     crr(i, 1) = crr(i, 1) & Space(1) & brr(drr(x2), 3)
    
33.                 End If
    
34.             End If
    
35.         Next
    
36.         .Range("f2").Resize(UBound(crr), 1) = crr
    
37.     End With
    
38. End Sub
    

复制代码

chxw68

参与一下。

Qs18

规则没有理解透彻

清风竹-

请看附件。

usedrange

1. Sub tt()
   
2.     Dim ar, br, m%, i%, dic, r%, b%, b2%, rr%
   
3.     Set dic = CreateObject("scripting.dictionary")
   
4.     ar = Sheet2.[a1].CurrentRegion
   
5.     For i = 2 To UBound(ar)
   
6.         dic(ar(i, 1)) = dic(ar(i, 1)) + 1
   
7.     Next i
   
8.     With Sheet1
   
9.         Randomize
   
10.         m = .[a1].End(4).Row
    
11.         ReDim br(1 To m, 1 To 1)
    
12.         rr = 1
    
13.         For Each k In dic.keys
    
14.             For i = 2 To m
    
15.                 If .Cells(i, 1) = k Then
    
16.                     With Sheet2
    
17.                         r = WorksheetFunction.Match(k, .Range("a1:a" & UBound(ar)), 0)
    
18.                         b = Int(dic(k) * Rnd() + r)
    
19.                         b2 = Int(dic(k) * Rnd() + r)
    
20.                         br(rr, 1) = .Cells(b, "b") & " " & Chr(Asc(k) - 32) & " " & .Cells(b2, "c")
    
21.                         rr = rr + 1
    
22.                     End With
    
23.                 End If
    
24.             Next i
    
25.         Next k
    
26.         .[e2].Resize(UBound(br), 1) = br
    
27.     End With
    
28.     Set dic = Nothing
    
29. End Sub
    

复制代码

usedrange

参与一下，看看对不对