vba随机组合文本标题不重复

哦哈尼哈尼

要求如上图，所写
随机组合文本.rar (16.14 KB, 下载次数: 13)

2018-5-20 23:33 上传

点击文件名下载附件

liulang0808

楼主的需求，没有看太明白的
建议结合附件举例再说明下
单纯提取不重复单元格，很好提取，使用字典即可，关键其他部分不明白

哦哈尼哈尼

liulang0808 发表于 2018-5-21 07:04
楼主的需求，没有看太明白的
建议结合附件举例再说明下
单纯提取不重复单元格，很好提取，使用字典即可， ...

重新传了。你看下能明白吗

哦哈尼哈尼

zopey

随机组合文本.zip (32.09 KB, 下载次数: 35)

2018-5-21 11:47 上传

点击文件名下载附件

哦哈尼哈尼

zopey 发表于 2018-5-21 11:47

大体是这样子，有点细节上不对，b1到g1单元格中的字符位置没有随机出在在组合标题中，全固定在一个位置了。组合后的标题字符数超出了60个字符。

zopey

比如说已抽取10个单元格，它们的顺序可以任意排列？

哦哈尼哈尼

zopey 发表于 2018-5-21 14:19
比如说已抽取10个单元格，它们的顺序可以任意排列？

是的，但必需包含b1到g1单元格中有的字符，没有的就不抽取

liulang0808

1. Sub 按钮1_Click()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     Set dr = CreateObject("scripting.dictionary")
   
4.    
   
5.     y = Application.InputBox("请输入生成标题数量：", "输入标题数量", 5, , , , , 1)
   
6.     If y = False Then
   
7.         MsgBox "请输入有效数字"
   
8.         Exit Sub
   
9.     End If
   
10.     Application.ScreenUpdating = False
    
11.    
    
12.     arr = [b1:g1]
    
13.     For j = 1 To UBound(arr, 2)
    
14.         If Len(arr(1, j)) > 0 Then
    
15.             dr(arr(1, j)) = ""
    
16.         End If
    
17.     Next j
    
18.     arr = Range([a2], Cells(Rows.Count, 1).End(3))
    
19.     For j = 1 To UBound(arr)
    
20.         If Not dr.exists(arr(j, 1)) Then
    
21.             d(arr(j, 1)) = ""
    
22.         End If
    
23.     Next j
    
24.    
    
25.     arr = [b1:g1]
    
26.     a = 2
    
27.     For i = 1 To y
    
28. l2:
    
29.         str1 = ""
    
30.         dr.RemoveAll
    
31.         For j = 1 To UBound(arr, 2)
    
32.             If Len(arr(1, j)) > 0 Then
    
33.                 dr(arr(1, j)) = ""
    
34.             End If
    
35.         Next j
    
36. l1:
    
37.         If dr.Count > 0 Then
    
38.             x = WorksheetFunction.RandBetween(0, 5)
    
39.             If x = 1 Then
    
40.                 x = WorksheetFunction.RandBetween(0, dr.Count - 1)
    
41.                 str1 = str1 & dr.keys()(x)
    
42.                 dr.Remove dr.keys()(x)
    
43.             Else
    
44.                 x = WorksheetFunction.RandBetween(0, d.Count - 1)
    
45.                 str1 = str1 & d.keys()(x)
    
46.             End If
    
47.             y1 = dr.Count
    
48.             If Len(str1) > 60 Then GoTo l2
    
49.             GoTo l1:
    
50.         End If
    
51.         If Len(str1) > 58 Then
    
52.             Cells(a, 8) = str1 & Space(60 - Len(str1))
    
53.             Cells(a, 9) = Len(Cells(a, 8))
    
54.             a = a + 1
    
55.         Else
    
56.             GoTo l2
    
57.         End If
    
58.     Next i
    
59. 
    
60.     Application.ScreenUpdating = True
    
61. End Sub
    

复制代码

liulang0808

附件内容供参考。。。。。。