[已解决]矩形区域中任选随机不重复值并按指定列数输出结果】

香川群子

规则如下：
① 从A1开始的多列区域为源数据，第1行为列标题，允许各列数据个数(行数)不等 （即部分含有空白单元格）
② 需要抽取个数n 由对话框输入数值后(自动Int取整)，但不得大于元素总个数m，也不能<1
③ 输出结果仍按同样列数……但行数会根据n大小自动决定
④ 输出结果为源数据区域间隔1列开始，第1行留空


下面是从A1开始多行多列的矩形区域中任意取n个随机不重复值的代码：

1. 
   
2. Sub RctDataRnd()
   
3.     Dim rw&, cl&, i&, j&, ii&, jj&, m&, n&, r&, t
   
4.    
   
5.     arr = [a1].CurrentRegion.Offset(1)
   
6.     m = Application.CountA([a1].CurrentRegion.Offset(1))
   
7.     rw = UBound(arr) - 1: cl = UBound(arr, 2)
   
8.     [a1].Offset(1, cl + 1).CurrentRegion = ""
   
9.     n = Int(Val(InputBox("How many ?" & vbCr & " [1 to " & m & "]", "Get Rand", 238)))
   
10.     If n <= 0 Or n > m Then MsgBox "HeadCounts is not correct.": Exit Sub
    
11.    
    
12.     Randomize
    
13.     For i = 1 To rw
    
14.         For j = 1 To cl
    
15.             Do
    
16.                 r = Int(Rnd() * ((rw - i + 1) * cl - j + 1)) + (i - 1) * cl + j - 1
    
17.                 ii = Int(r / cl) + 1: jj = r Mod cl + 1
    
18.                 t = arr(ii, jj)
    
19.                 If t <> "" Then
    
20.                     arr(ii, jj) = arr(i, j): arr(i, j) = t
    
21.                     n = n - 1: If n = 0 Then Exit For Else Exit Do
    
22.                 End If
    
23.             Loop
    
24.         Next
    
25.         If n = 0 Then
    
26.             For j = j + 1 To cl
    
27.                 arr(i, j) = ""
    
28.             Next
    
29.             Exit For
    
30.         End If
    
31.     Next
    
32.     [a1].Offset(1, cl + 1).Resize(i, cl) = arr
    
33. End Sub
    

复制代码

附件有更新，加了元素总数m的计算。

张雄友

香川群子 发表于 2014-3-5 23:18
规则如下：
① 从A1开始的多列区域为源数据，第1行为列标题，允许各列数据个数(行数)不等 （即部分含有空白 ...

结果输出的列数可以用 inputbox 来选择就好了，附件限定输出4列（即源数据的最大列数），

假如用  inputbox 来选择输出，可以是1 列，5列，......用户可以根据需要决定，人性化。

张雄友

香川群子 发表于 2014-3-5 23:18
规则如下：
① 从A1开始的多列区域为源数据，第1行为列标题，允许各列数据个数(行数)不等 （即部分含有空白 ...

老师在？

结果输出的列数可以用 inputbox 来选择就好了，附件限定输出4列（即源数据的最大列数），

假如用  inputbox 来选择输出，可以是1 列，5列，......用户可以根据需要决定，人性化。

香川群子

张雄友 发表于 2014-3-6 07:51
老师在？

结果输出的列数可以用 inputbox 来选择就好了，附件限定输出4列（即源数据的最大列数），

如果输出列要和源数据列不同，这样肯定会麻烦一点。

第一要重新定义数组、第二每次存放也要重新转换计算输出位置。

我觉得没有这个必要了。


告诉你一个取巧的方法：
如果需要输出的列数比源数据的列数要多，你可以在第1行增加列标题直到需要列数为止。
这样我的代码输出结果，就是当前源数据的、已经扩展的列数了。（比原始列数大）


如果需要输出的列数比源数据的列数要少，
如果工作表的行数允许，你可以把源数据合并后减少至你需要的列数。
这样我的代码输出结果，就是当前源数据的、已经缩减的列数了。（比原始列数小）



最后明确告诉你，不想帮你改写代码了。你需要的话可以自己改写。

张雄友

香川群子 发表于 2014-3-6 09:36
如果输出列要和源数据列不同，这样肯定会麻烦一点。

第一要重新定义数组、第二每次存放也要重新转换计 ...

下标越界，不知问题出在哪？请再帮修改一下，谢谢了！

1. Sub RctDataRnd() '输出列数修改,输出的列数可以用 inputbox 来选择,假如用  inputbox 来选择输出，可以是1 列，5列，......用户可以根据需要决定，人性化。
   
2.     Dim rw&, cl&, i&, j&, ii&, jj&, m&, n&, r&, t, k&, YY, crr
   
3.    
   
4.     arr = [a1].CurrentRegion.Offset(1)
   
5.     m = Application.CountA([a1].CurrentRegion.Offset(1))
   
6.     rw = UBound(arr) - 1: cl = UBound(arr, 2)
   
7.     [a1].Offset(1, cl + 1).CurrentRegion = ""
   
8.     n = Int(Val(InputBox("How many ?" & vbCr & " [1 to " & m & "]", "Get Rand", 12))) '抽取个数n
   
9.     If n <= 0 Or n > m Then MsgBox "HeadCounts is not correct.": Exit Sub
   
10.    
    
11.     Randomize
    
12.     For i = 1 To rw
    
13.         For j = 1 To cl
    
14.             Do
    
15.                 r = Int(Rnd() * ((rw - i + 1) * cl - j + 1)) + (i - 1) * cl + j - 1
    
16.                 ii = Int(r / cl) + 1: jj = r Mod cl + 1
    
17.                 t = arr(ii, jj)
    
18.                 If t <> "" Then
    
19.                     arr(ii, jj) = arr(i, j): arr(i, j) = t
    
20.                     n = n - 1: If n = 0 Then Exit For Else Exit Do
    
21.                 End If
    
22.             Loop
    
23.         Next
    
24.         If n = 0 Then
    
25.             For j = j + 1 To cl
    
26.                 arr(i, j) = ""
    
27.             Next
    
28.             Exit For
    
29.         End If
    
30.     Next
    
31.     '[a1].Offset(1, cl + 1).Resize(i, cl) = arr '输出列数？？？？？
    
32.     ReDim jg$(1 To n, 1 To 1)
    
33. 
    
34.     On Error Resume Next
    
35.     If n < 65536 Then
    
36.     YY = Val(InputBox("请输入要生成的列数?", ""))
    
37.      r = Int(n / YY) + 1
    
38.     ReDim crr(1 To r, 1 To YY)
    
39.     For i = 1 To r
    
40.     For j = 1 To YY
    
41.      crr(i, j) = jg((i - 1) * YY + j, 1)
    
42.      Next j
    
43.      Next i
    
44.      Set Rng = Application.InputBox("请选择存放区域(单个单元格即可)", "VBA", , , , , , 8)
    
45.      Rng.CurrentRegion.ClearContents
    
46.      Rng.Resize(r, YY) = crr
    
47. End If
    
48. 
    
49. End Sub
    

复制代码

香川群子

建议楼主把标题改一下以符合实际内容：
【矩形区域中任选随机不重复值并按指定列数输出结果】

1. Sub kagawa_Rand()
   
2.     Dim rw&, cl&, i&, i1&, j&, j1&, k&, l&, m&, n&, r&, t, tms#
   
3.     tms = Timer
   
4.    
   
5.     arr = Sheet1.[a1].CurrentRegion.Offset(1) '获取不含第1行列标题的源数据读入数组arr
   
6.     rw = UBound(arr) - 1: cl = UBound(arr, 2) '得到二维数组arr的行数rw、列数cl
   
7.     m = Application.CountA(Sheet1.[a1].CurrentRegion.Offset(1)) '统计区域中非空白值有效个数m
   
8.    
   
9.     n = Int(Val(InputBox("How many ?" & vbCr & " [1 to " & m & "]", "Get Rand", m))) '抽取个数n
   
10.     If n < 1 Or n > m Then MsgBox "Rand Numbers not correct !": Exit Sub 'n超出1 to m 范围时停止
    
11.      
    
12.     l = Int(Val(InputBox("How many columns ?" & vbCr & " [" & n \ Cells.Rows.Count + 1 & " to " & IIf(n < Cells.Columns.Count, n, Cells.Columns.Count) & "]", "Get Rand", Int(n ^ 0.5))))
    
13.     '指定输出列数 根据实际抽取n和工作表最大行数、列数比较后计算出列数可行范围
    
14.    If l < n \ Cells.Rows.Count + 1 Or l > Cells.Columns.Count Then    MsgBox "Columns not correct !": Exit Sub ' l 超出列数可行范围时停止
    
15.     ReDim brr(n \ l, l - 1)
    
16.    
    
17.     Randomize '随机种子初始化 保证每次运行宏产生的随机值不同
    
18.     For i = 1 To rw
    
19.         For j = 1 To cl
    
20.             Do
    
21.                 r = Int(Rnd() * ((rw - i + 1) * cl - j + 1)) + (i - 1) * cl + j - 1
    
22.                 i1 = Int(r / cl) + 1: j1 = r Mod cl + 1: t = arr(i1, j1)
    
23.                 If t <> "" Then
    
24.                     arr(i1, j1) = arr(i, j): arr(i, j) = t
    
25.                     brr(k \ l, k Mod l) = t: k = k + 1
    
26.                     If k = n Then Exit For Else Exit Do
    
27.                 End If
    
28.             Loop
    
29.         Next
    
30.         If k = n Then Exit For
    
31.     Next
    
32.    
    
33.     Sheet2.Activate
    
34.     [a2].CurrentRegion = ""
    
35.     [a1].Resize(n \ l + 1, l) = brr
    
36.     MsgBox Format(Timer - tms, "0.000s ") & vbCr & "Get : " & n & vbCr & "rows: " & (n - 1) \ l + 1 & " /columns: " & IIf(n > l, l, n)
    
37. End Sub

复制代码

香川群子

补充：
Sheet1中最后一行一定要空着，不要使用。否则会出错。

Sheet2输出结果时，最后1行也不会被用到。
而且现在是优先逐行输出，整行所有列都填满后才会进入下一行。