[已解决]随机排序并提取合格列数据的问题

阿丽儿

grf1973 发表于 2015-8-20 15:22
原代码是香川做的吧？代码26行--44行是新加进去的，用于判断并生成结果数组。46--49行是原代码中生成工作簿 ...

老师您好,麻烦您加一个自动循环的代码进去好吗?让程序自动执行若干次.比如让程序自动执行10次,那么第一次执行完后,结果另存为01,第二次执行完后,结果另存为02......第十次执行完后,结果另存为10.

谢谢了!

grf1973

1. Sub kagawa()
   
2.     Dim i&, j&, k&, m&, n&, r&, t&, tms#
   
3.     tms = Timer
   
4.    
   
5.     ar = [a1].CurrentRegion
   
6.     m = UBound(ar)
   
7.     ReDim a&(m - 1)
   
8.     For i = 1 To m
   
9.         a(i - 1) = ar(i, 1)
   
10.     Next
    
11.    
    
12.       
    
13.     Application.ScreenUpdating = False
    
14.     Application.DisplayAlerts = False
    
15.    
    
16.     For Each Sh In Worksheets     '删除其他工作表
    
17.         If Sh.Name <> ActiveSheet.Name Then Sh.Delete
    
18.     Next
    
19.    
    
20.     Randomize
    
21.     c = 16000   '列数
    
22.     gs = 10     '生成的工作簿数
    
23.    
    
24.     cs = InputBox("请输入执行次数", , 5)
    
25.     For xx = 1 To cs
    
26.         ReDim arr&(m, 1 To c)
    
27.         ReDim brr(m + 5, 1 To c)
    
28.         p = 0
    
29.         For k = 1 To gs
    
30.             wName = Right(0 & k, 2) & ".xlsx"
    
31.             For j = 1 To c
    
32.                 For i = 0 To m - 1
    
33.                     r = Int(Rnd * (m - i)) + i
    
34.                     t = a(r): a(r) = a(i): a(i) = t: arr(i, j) = t
    
35.                 Next
    
36.                 '''''''''''''''''''''''''  新增判断部分
    
37.                 r = m: n = 0      'r是最末一行（有数据的下一行）
    
38.                 For i = r To 3 * r / 4 - 1 Step -1     '只需判断最末一行至最末一行的3/4处
    
39.                     n = n + 1
    
40.                     If arr(i, j) = n And i > 3 * n Then     '倒数第n行数值为n
    
41.                         If arr(i - n, j) = n And arr(i - 2 * n, j) = n And arr(i - 3 * n, j) = n Then
    
42.                             p = p + 1
    
43.                             For kk = 0 To m - 1
    
44.                                 brr(kk, p) = arr(kk, j)
    
45.                             Next
    
46.                            
    
47.                             brr(kk + 2, p) = n
    
48.                             brr(kk + 3, p) = wName
    
49.                             brr(kk + 4, p) = Split(Cells(1, j).Address, "$")(1)     '第j列的列号
    
50.                             Exit For
    
51.                         End If
    
52.                     End If
    
53.                 Next
    
54.                 '''''''''''''''''''''''''''''''''''''''
    
55.             Next
    
56.         Next
    
57.         
    
58.         If p > 0 Then
    
59.             Sheets.Add after:=Sheets(Sheets.Count)
    
60.             With ActiveSheet
    
61.                 .Cells.ClearContents
    
62.                 .[a1].Resize(m + 5, p) = brr
    
63.                 .Name = Format(xx, "00")
    
64.             End With
    
65.         End If
    
66.     Next
    
67.    
    
68.     Application.ScreenUpdating = True
    
69.     MsgBox Format(Timer - tms, "0.000s")
    
70. End Sub
    

复制代码