[已解决]批量生成随机数中植入指定数据的问题

香川群子

呵呵，文件数变量定义为整数型，最大只能到 2^15-1=32767

把代码中的 f% 改成 f& 就可以增加到 2,147,483,647


自己能改么？

代码前面几句：

Sub RndNumCol()
    tms = Timer
   
    Dim Mx&, Mn&, Rs&, Col%, Fs%
    Dim i&, j&, k&, n%, f%, rw&, cl%, r&, c%, c1%, c2%   


红色部分 f% 改为 f& 就好了：
Sub RndNumCol()
    tms = Timer
   
    Dim Mx&, Mn&, Rs&, Col%, Fs%
    Dim i&, j&, k&, n%, f&, rw&, cl%, r&, c%, c1%, c2%   

小小玩童

香川群子 发表于 2013-3-1 08:53
呵呵，文件数变量定义为整数型，最大只能到 2^15-1=32767

把代码中的 f% 改成 f& 就可以增加到 2,147,48 ...

已改，谢谢老师帮助！我以为老师近期蜜月忘了这事了，没想到还能在百忙中记起，有机会请你喝咖啡。一定！

小小玩童

香川群子 发表于 2013-3-1 08:53
呵呵，文件数变量定义为整数型，最大只能到 2^15-1=32767

把代码中的 f% 改成 f& 就可以增加到 2,147,48 ...

老师您好。不好意思，又要请教您了。
上次按你的要求在把f%改为f&后，一切正常了。因工作需要，这次要造15万表格，但造到110842处，就提示出错了。不知是何原因？

香川群子

出错信息是什么？

代码在哪里停下？

小小玩童

香川群子 发表于 2013-3-17 19:13
出错信息是什么？

代码在哪里停下？

经过几台脑试造：目标是15万，其中有一台造到108339处，出错；另一台目标也是15万，造到11万多点，也出错停下。

小小玩童

香川群子 发表于 2013-3-17 19:13
出错信息是什么？

代码在哪里停下？

Sub RndNumCol()
    tms = Timer
    Dim Mx&, Mn&, Rs&, Col%, Fs%
    Dim i&, j&, k&, n%, f&, rw&, cl%, r&, c%, c1%, c2%
    Mx = Range("Mx"): Mn = Range("Mn"): If Mx <= Mn Then MsgBox "嵟戝悢昁戝槹嵟彫悢.": Exit Sub
    Rs = Range("Rs"): If Rs < 1 Or Rs > 1048576 Then MsgBox "峴悢乮1-1048576)": Exit Sub
    If Rs Mod (Mx - Mn + 1) Then MsgBox "惗惉峴悢惀帤悢揑攞悢": Exit Sub
    Col = Range("Col"): If Col < 1 Or Col > 256 Then MsgBox "楍悢": Exit Sub
    ReDim Arr(1 To Rs, 0 To Col)
    '    Bs = Rs / (Mx - Mn + 1) '攞悢=庢悢槩悢揑攞悢
    For j = 1 To Rs / (Mx - Mn + 1)
        For i = Mn To Mx
            k = k + 1
            Arr(k, Col) = i
        Next
    Next
    lxs = Range("LXS"): c1 = Range("CSX"): c2 = Range("CSS")
    n = UBound(lxs)
    Randomize
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    For f = 1 To Range("Fs")
        Workbooks.Add 1
        For cl = 0 To Col - 1
            For rw = Rs To 1 Step -1
                r = Int(Rnd * rw) + 1
                Arr(rw, cl) = Arr(r, Col)  't=r
                Arr(r, Col) = Arr(rw, Col)  'r=rw
                Arr(rw, Col) = Arr(rw, cl)  'rw=t
            Next
            c = Int(Rnd * (c2 - c1 + 1) + c1)
            crr = GetRndAvg(1, Rs - n + 1, c, , n)
            For c = 1 To c
                r = crr(c) - 1
                For k = 1 To n
                    Arr(r + k, cl) = lxs(k, 1)
                Next
            Next
        Next
        ActiveSheet.Cells(1, 1).Resize(Rs, Col) = Arr
       ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & f    '& ".xlsx"            调试时，指向这里，变为黄色了。
        ActiveWorkbook.Close
    Next
    Application.ScreenUpdating = True
    MsgBox Format(Timer - tms, "0.000s")
End Sub
Function GetRndAvg(a, b, m, Optional d = 0, Optional h = 1, Optional s = 0)    '嬫娫巜掕嬒鷫悘婘晄廳暋拪?
    Randomize
    '    Dim i&, n&, r&, t&
    a = a * 10 ^ d: b = b * 10 ^ d
    ReDim c(1 To m)
    If b - a < m * h Then c(1) = a Else c(1) = Int(((b - a + 1) / m - h) * Rnd()) + a
    If m = 1 Then GetRndAvg = c: Exit Function
    '    n = 0
    Do
        n = n + 1
        If b - c(n) < (m - n) * h Then
            If c(n) + h <= b Then
                c(n + 1) = c(n) + h
            Else
                GoTo Ext
            End If
        Else
            c(n + 1) = c(n) + Int(((b - c(n) + 1) / (m - n) - h) * Rnd() * 2) + h
        End If
    Loop Until n = m - 1
    c(m) = c(n) + Int((b - c(n) + 1 - h) * Rnd()) + h
Ext:
    If s = 0 Then
        For i = 1 To m    '惓彉愻攙
            r = Int((m - i + 1) * Rnd()) + i
            t = c(r): c(r) = c(i): c(i) = t / 10 ^ d
        Next
    ElseIf s = -1 Then
        For i = 1 To m \ 2    '搢彉岎?
            t = c(m - i + 1) / 10 ^ d: c(m - i + 1) = c(i) / 10 ^ d: c(i) = t
        Next
        If m Mod 2 = 1 Then c(i) = c(i) / 10 ^ d
    Else
        For i = 1 To m    '惓彉
            c(i) = c(i) / 10 ^ d
        Next
    End If
    GetRndAvg = c
End Function