楼主
kevinchengcw |
Q: 如何利用vba生成随机姓名列表？
A: 生成代码如下：
- Sub test()
- Dim Arr, Arr2, Arr3, I%, N&, S As Boolean, Str$, Dic, A&, B&
- N = Val(InputBox("请输入要生成的人名数：")) '输入要生成的随机人名数量
- If N = 0 Then Exit Sub '如果未输入或点了取消则退出程序
- Set Dic = CreateObject("scripting.dictionary") '创建字典项目，用于清除生成的重复的人名
- With Sheet1 '从sheet1中读取数据并随机生成姓名
- Arr = .Range(.[a2], .Cells(.Rows.Count, 1).End(3)) '读取百家姓放入数组
- Arr2 = .Range(.[b2], .Cells(.Rows.Count, 2).End(3)) '读取男子名常用字放入数组
- Arr3 = .Range(.[c2], .Cells(.Rows.Count, 3).End(3)) '读取女子名常用字放入数组
- Do '循环执行
- Str = "" '先清空用于存储生成的名字的变量
- S = Rnd > 0.5 '用取得的随机数来判断生成男子名还是女子名
- I = 2 + IIf(Rnd > 0.8, 0, 1) '用随机数确定生成的名字的字符数（80%的几率为三个字）
- If S Then '如果是男子名，则
- A = Int(Rnd * (UBound(Arr) - 2)) + 2 '取得姓对应的数组下标
- B = Int(Rnd * (UBound(Arr2) - 2)) + 2 '取得名字的对应下数组下标
- Str = Arr(A, 1) & Arr2(B, 1) '串接名字
- If I > 2 Then '如果名字的字符数大于2，则再得一次名字的字符下标并串接给字符串变量
- B = Int(Rnd * (UBound(Arr2) - 2)) + 2
- Str = Str & Arr2(B, 1)
- End If
- Else '如果是女子名，则取对应的女子名数组内容，处理方式同上
- A = Int(Rnd * (UBound(Arr) - 2)) + 2
- B = Int(Rnd * (UBound(Arr3) - 2)) + 2
- Str = Arr(A, 1) & Arr3(B, 1)
- If I > 2 Then
- B = Int(Rnd * (UBound(Arr3) - 2)) + 2
- Str = Str & Arr3(B, 1)
- End If
- End If
- Dic(Str) = "" '将随机姓名放入字典中
- Loop Until Dic.Count = N '如果字典项目数量达到输入的数值则跳出循环
- End With
- With Sheet2 '将结果写入sheet2中
- .Cells.Clear '清空原有内容
- If Dic.Count > 65536 Then '防止数量太多时无法转置及数据超出单元格最大行号的情况
- Arr = Dic.keys
- For N = LBound(Arr) To UBound(Arr)
- Cells((N Mod 65536) + 1, N \ 65536 + 1) = Arr(N)
- Next N
- Else '数量少时直接转置
- .[a1].Resize(Dic.Count, 1) = Application.Transpose(Dic.keys) '转置字典的keys值
- End If
- End With
- Set Dic = Nothing '清空字典项目
- End Sub
附示例文件。
 随机姓名生成测试.rar
|