VBA随机填充 感谢！！

cqz1314

求VBA代码

将【词语库】中第1课中的拼音和词语随机填充到【第1课】中

奇数行是拼音  偶数行是与拼音对应的词语

填充的位置是随机的 但拼音和词语到对应

======
一本语书有32课

第1课 引用【词语表】的A2-B列，范围用[A2：B]这种形式

第2课 引用【词语表】的C2-D列，

……

不管词语多少都靠上填充。


辛苦老师们了 感谢

ww87725244

1、开始说填充位置随机，后面又说靠上填充，搞不懂了。
2、随机填充多少个？

cqz1314

ww87725244 发表于 2018-4-5 15:02
1、开始说填充位置随机，后面又说靠上填充，搞不懂了。
2、随机填充多少个？

先谢了

A B里的都填充有的都填充

每列5个词  靠上填充

ww87725244

cqz1314 发表于 2018-4-5 15:27
先谢了

A B里的都填充有的都填充

建议最好模拟一个结果

cqz1314

ww87725244 发表于 2018-4-5 15:34
建议最好模拟一个结果

cqz1314

是我
求解

感谢老师帮忙

zorsite

每列只有5个词语没有实现，随机填充词语倒是实现了。
代码比较糙，权当抛砖引玉了。

1. Sub 随机填词()
   
2. '每两列为一课，for 循环step =2
   
3. '每课的词语数量不一样，获取lastrow
   
4. '生成和词语数量同样的不重复随机数，然后按照随机数的顺序进行填充
   
5. Dim sht As Worksheet
   
6. Dim lastcolumn As Integer, lastrow As Integer, i As Integer, j As Integer
   
7. Dim wordscount As Integer
   
8. Dim arr, brr, crr()
   
9. 
   
10. 
    
11. Application.DisplayAlerts = False
    
12. For Each sht In Worksheets
    
13.     If sht.Name <> "词语库" Then sht.Delete
    
14. Next
    
15. With Sheets("词语库")
    
16.     lastcolumn = .UsedRange.Columns.Count
    
17.     For i = 1 To lastcolumn Step 2
    
18.         lastrow = .Cells(Rows.Count, i).End(xlUp).Row
    
19.         If lastrow > 1 Then '如果词语数量不为零
    
20.             arr = Range(.Cells(1, i), .Cells(lastrow, i + 1)).Value '把该课的词语读入数组
    
21.             wordscount = UBound(arr) - 1 '词语的数量
    
22.             brr = rndnum(1, wordscount) '生成不重复随机数
    
23.             Worksheets.Add after:=Worksheets(Worksheets.Count)
    
24.             With Worksheets(Worksheets.Count)
    
25.                 .Name = arr(1, 1)     '第几课
    
26.                 ReDim crr(1 To wordscount * 2)
    
27.                 For j = 1 To wordscount
    
28.                     '注意：arr是从1开始，brr是从0开始，而且为了为工作表起名，arr的第一个数据是“第×课”
    
29.                     'brr(j-1)是为了满足brr的索引从0开始，取出brr(j-1)之后再+1是为了防止把arr的第一个元素“第×课”取出来
    
30.                     crr(j * 2 - 1) = arr(brr(j - 1) + 1, 1)
    
31.                     crr(j * 2) = arr(brr(j - 1) + 1, 2)
    
32.                 Next
    
33.                 .Cells(1, 1).Resize(wordscount * 2).Value = Application.WorksheetFunction.Transpose(crr)
    
34.             End With
    
35.         End If
    
36.     Next
    
37. End With
    
38. Application.DisplayAlerts = True
    
39. End Sub
    
40. 
    
41. Function rndnum(ByRef startnum As Integer, ByRef endnum As Integer)
    
42. '生成不重复随机数
    
43. Dim d As Object
    
44. Dim s As Integer
    
45. Dim numcount As Integer
    
46. Set d = CreateObject("scripting.dictionary")
    
47. numcount = endnum - startnum + 1
    
48. Do Until d.Count = numcount
    
49.     s = Application.WorksheetFunction.RandBetween(startnum, endnum)
    
50.     d(s) = ""
    
51. Loop
    
52. rndnum = d.keys '返回不重复随机数数组
    
53. End Function
    

复制代码

cqz1314

zorsite 发表于 2018-4-5 23:11
每列只有5个词语没有实现，随机填充词语倒是实现了。
代码比较糙，权当抛砖引玉了。

辛苦了
我试试效果

cqz1314

zorsite 发表于 2018-4-5 23:11
每列只有5个词语没有实现，随机填充词语倒是实现了。
代码比较糙，权当抛砖引玉了。

老师 这种方式不行呀

我还在打成试卷 这样的话每次都在重新排版

ww87725244

1. Sub aa()
   
2. Dim sh As Worksheet, arr, i&, rng As Range, ar(), k&, m&, ar1, s&, p&, n&
   
3. Dim d As Object
   
4. Set d = CreateObject("scripting.dictionary")
   
5. With Sheet1
   
6.     For Each rng In .Range(.Cells(1, 1), .Cells(1, .UsedRange.Columns.Count))
   
7.         If rng.Offset(1, 0) = "" Then
   
8.             MsgBox rng.Value & "不存在相关数据"
   
9.             Exit Sub
   
10.         End If
    
11.         If rng.Value <> "" Then
    
12. 100:
    
13.             For Each sh In Worksheets
    
14.                 If rng.Value = sh.Name Then
    
15.                     s = s + 1
    
16.                     arr = rng.Offset(1, 0).Resize(.Cells(.Columns(rng.Column).Rows.Count, rng.Column).End(xlUp).Row - 1, 2)
    
17.                     Do
    
18.                         Randomize
    
19.                         k = Int(Rnd() * UBound(arr) + 1)
    
20.                         d(k) = arr(k, 1) & "" & arr(k, 2)
    
21.                     Loop Until d.Count = UBound(arr)
    
22.                     ar1 = d.items
    
23.                     p = 2
    
24.                     n = 1
    
25.                     ReDim Preserve ar(1 To UBound(ar1) / 2, 1 To 5)
    
26.                     For m = 0 To UBound(ar1)
    
27.                         If m Mod 5 = 0 And m <> 0 Then
    
28.                             p = p + 2
    
29.                             n = 1
    
30.                         End If
    
31.                         ar(p - 1, n) = Split(ar1(m), "")(0)
    
32.                         ar(p, n) = Split(ar1(m), "")(1)
    
33.                         n = n + 1
    
34.                     Next
    
35.                     sh.Range("a1").Resize(UBound(ar), UBound(ar, 2)) = ar
    
36.                     Erase ar
    
37.                     d.RemoveAll
    
38.                 End If
    
39.             Next
    
40.             If s = 0 Then
    
41.                 Set sh = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    
42.                 sh.Name = rng.Value
    
43.                 GoTo 100
    
44.             End If
    
45.         End If
    
46.         s = 0
    
47.     Next
    
48. End With
    
49. End Sub

复制代码