随机数自动连续生成新文件

阿瑛

附件 随机数.rar (47.8 KB, 下载次数: 47)

2014-9-26 13:25 上传

点击文件名下载附件
谢谢！

在一个QQ群里悬偿已解决。

qcw811206

qcw911@163.com
下载不了

dsmch

1. Const m& = 49, s$ = "00"
   
2. Sub kagawa()
   
3.     Dim i&, j&, k&, n&, t, tms#
   
4.    
   
5.     If [b11] <> "" Then [a10].CurrentRegion.Offset(1) = "": Exit Sub
   
6.     k = Val(InputBox("Please input Number of Data Sheets: " & m & " x ?", "GetRand", 490))
   
7.     If k = 0 Then Exit Sub Else If m * k + 10 > Cells.Rows.Count Then k = (Cells.Rows.Count - 10) \ m
   
8.     tms = Timer
   
9.    
   
10.     arr = Application.Transpose(Application.Transpose([b1].CurrentRegion))
    
11.     n = UBound(arr)
    
12.    
    
13.     Randomize
    
14.     For k = 1 To k
    
15.         ReDim brr(1 To m, n)
    
16.         For i = 1 To m
    
17.             brr(i, 0) = Right(0 & k, 2) & "-" & Format(i, s)
    
18.             For j = 1 To n
    
19.                 r = Int(Rnd * (n - j + 1) + j)
    
20.                 t = arr(r): arr(r) = arr(j): arr(j) = t: brr(i, j) = t
    
21.             Next
    
22.         Next
    
23.         [a11].Offset(m * (k - 1)).Resize(m, 1 + n) = brr
    
24.     Next
    
25.     MsgBox Format(Timer - tms, "0.000s")
    
26.     Call 生成新文件
    
27. End Sub
    
28. Sub 生成新文件()
    
29. Dim arr, brr, crr(1 To 60000, 1 To 3)
    
30. Dim i&, n%, s&
    
31. arr = Range("a10").CurrentRegion
    
32. brr = Range("b1").CurrentRegion
    
33. n = UBound(brr, 2) + 1
    
34. For i = 2 To UBound(arr)
    
35.     If arr(i, 2) = arr(i, n - 1) And arr(i, 3) = arr(i, n) Then
    
36.         s = s + 1
    
37.         crr(s, 1) = i + 9
    
38.         crr(s, 2) = arr(i, 1)
    
39.         crr(s, 3) = arr(i, 2) & "=" & arr(i, 3)
    
40.     End If
    
41. Next
    
42. If s > 0 Then
    
43.     [a4] = [a4] + 1
    
44.     Application.ScreenUpdating = False
    
45.     Application.DisplayAlerts = False
    
46.     Application.SheetsInNewWorkbook = 1
    
47.     With Workbooks.Add
    
48.         .Sheets(1).[b:b].NumberFormatLocal = "@"
    
49.         .Sheets(1).Range("a1").Resize(s, 3) = crr
    
50.         .SaveAs Filename:=ThisWorkbook.Path & "" & ThisWorkbook.Sheets(1).[a4] & ".xls"
    
51.         .Close 1
    
52.     End With
    
53.     Application.SheetsInNewWorkbook = 3
    
54.     Application.DisplayAlerts = True
    
55.     Application.ScreenUpdating = True
    
56. End If
    
57. End Sub

复制代码

dsmch

………………

阿瑛

dsmch 发表于 2014-9-26 14:28
………………

老师您好，下载试了一下，设定490*49时，出24010数据，程序运行正常。

当设定为19208*49时，出941192数据，第一步，也就是原来的一步，数据能出来，但后面就运行不正常了。

提示：运行时错误 7
          内存溢出

点击  调试   指向第四句

Sub 生成新文件()

Dim arr, brr, crr(1 To 980000, 1 To 3)

Dim i&, n&, s&

arr = Range("a10").CurrentRegion

brr = Range("b1").CurrentRegion

n = UBound(brr, 2) + 1: s = 0

For i = 2 To UBound(arr)

    If arr(i, 2) = arr(i, n - 1) And arr(i, 3) = arr(i, n) Then

说明：第二句我改为980000
因运行出错，我把第三句中的n%改为了n&,但还是出错。

另外：输出数据时，要实现自动，即第一步数据，出来后，生成新文件  1，附件中的数据，就不要了，然后又自动运行，数据出来后，生成新文件 2；依此类推。那个a4位置，可用来填写循环的次数。比如：我填写20，程序就自动运行20次，相应会生成20个新文件。

dsmch

Sub 生成新文件()
Dim arr, brr, crr(1 To 60000, 1 To 3)
Dim i&, n&, s&
arr = Range("a10").CurrentRegion
brr = Range("b1").CurrentRegion
n = UBound(brr, 2) + 1
For i = 2 To UBound(arr)
    If arr(i, 2) = arr(i, n - 1) And arr(i, 3) = arr(i, n) Then
        s = s + 1
        crr(s, 1) = i + 9
        crr(s, 2) = arr(i, 1)
        crr(s, 3) = arr(i, 2) & "=" & arr(i, 3)
    End If
Next
If s > 0 Then
    [a4] = [a4] + 1
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.SheetsInNewWorkbook = 1
    With Workbooks.Add
        .Sheets(1).[b:b].NumberFormatLocal = "@"
        .Sheets(1).Range("a1").Resize(s, 3) = crr
        .SaveAs Filename:=ThisWorkbook.Path & "\" & ThisWorkbook.Sheets(1).[a4] & ".xls"'改为07或10文件后缀名试试   
     .Close 1
    End With
    Application.SheetsInNewWorkbook = 3
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End If
End Sub

阿瑛

dsmch 发表于 2014-9-26 14:28
………………

老师您好！
设定为49*7203，产生352947，运行正常，另存为新文件，也正常。
设定为49*9604，产生470596，运行正常，另存为新文件，开始出错。

提示是内存溢出。电脑内存为4G。

阿瑛

dsmch 发表于 2014-9-26 16:37
Sub 生成新文件()
Dim arr, brr, crr(1 To 60000, 1 To 3)
Dim i&, n&, s&

我一下载后就用07运行的，里面的输出后缀也由xls 改为 xlsx了。

阿瑛

dsmch 发表于 2014-9-26 16:37
Sub 生成新文件()
Dim arr, brr, crr(1 To 60000, 1 To 3)
Dim i&, n&, s&

还是不行。好象超过36万行就不能另存为新文件了。实际工作中，是94万行。

阿瑛

dsmch 发表于 2014-9-26 16:37
Sub 生成新文件()
Dim arr, brr, crr(1 To 60000, 1 To 3)
Dim i&, n&, s&

其实，并不是另存为的时候出的错，而是在提取数据的时候，程序就过不了了。即，第一步数据出来后，要提取BC与最后两个相同的数时，这时候容易出错。

前些天，写了一个程序，94万数据，出来后，要提取BC列与最后两列相同的数据（那个程序设为EF列与最后两列），把94万数据，复到到程序中后，相同的程序，有几个，都提示内存溢出。后来有个程序，顺利过关。这说明并不是内存的问题。

附代码，有些关键句也许有用，可以参考。

Sub ll()
    Dim arr, i&, m&, n&, rend&, cend&, brr, crr
    With Sheet2
        rend = .Range("a" & .Cells.Rows.Count).End(xlUp).Row
        cend = .Cells(1, .Cells.Columns.Count).End(xlToLeft).Column
        arr = .Range("a1:F" & rend)
        crr = .Range(.Cells(1, cend - 1), .Cells(rend, cend))
    End With
    ReDim brr(1 To rend, 1 To 6)
    For i = 1 To UBound(arr)
        If arr(i, 5) = crr(i, 1) Then
            If arr(i, 6) = crr(i, 2) Then
                m = m + 1
                For n = 1 To 6
                    brr(m, n) = arr(i, n)
                Next
            End If
        End If
    Next
    Sheet1.Range("a1").Resize(m, 6) = brr
End Sub