用Norm_inv或优化函数将随机数生成为三位数

Question

我写了一个宏从样本中生成随机数。

RNG代码是：

For i = 6 To LR

    Set row = RANGE(Cells(i, 8), Cells(i, LC))

    prumer = Application.Average(row)
    smodch = Application.stdev(row)
    
    For A = B To LCNEW
        Cells(i, A).Value = Application.Norm_Inv(Rnd(), prumer, smodch)
        Cells(i, A).Value = Application.ROUND(Cells(i, A).Value, 3)
        Cells(i, A).NumberFormat = "0.000"
    Next A
    
Next i

它需要一行，计算平均值和stdev，然后执行这些操作。

在我的电脑上，它运行得很快，就像5-10秒的80行，有10个数字，并计算出100个随机数。

在一台较旧的计算机上，它运行大约5分钟！怎样才能把范数计算成三位数，或者优化它呢？

整个守则：

Sub RNGTOX()

   Dim lastcell As RANGE
   Dim row As RANGE
   Dim i As Long
   Dim A As Long
   Dim B As Long
   Dim prumer As Variant
   Dim smodch As Variant
   Dim LR As Long
   Dim LC As Long
   Dim ocislovani As RANGE
   Dim sSIDE As Worksheet

If RANGE("H6").Value = vbNullString Then
    MsgBox "Chybí data."
    Exit Sub
End If
            
Application.ScreenUpdating = False
     
Set sSIDE = ActiveSheet
Set lastcell = ActiveSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious)

LR = Cells(Rows.count, 1).End(xlUp).row
LC = Cells(6, Columns.count).End(xlToLeft).Column
B = LC + 1
LCNEW = RANGE("B2").Value + 7

If LCNEW <= LC Then
    MsgBox "Počet už je dosažený. Není třeba dopočítávat."
    Exit Sub
Else
End If

'ocislovani souboru
Set ocislovani = sSIDE.RANGE(sSIDE.Cells(5, 8), sSIDE.Cells(5, LCNEW))

counter_cisla = 1
For Each cell_a In ocislovani
    cell_a.Value = counter_cisla
    counter_cisla = counter_cisla + 1
Next cell_a

'i radek, A sloupec
For i = 6 To LR

    Set row = RANGE(Cells(i, 8), Cells(i, LC))

    prumer = Application.Average(row)
    smodch = Application.stdev(row)
    
    For A = B To LCNEW
        Cells(i, A).Value = Application.Norm_Inv(Rnd(), prumer, smodch)
        Cells(i, A).Value = Application.ROUND(Cells(i, A).Value, 3)
        Cells(i, A).NumberFormat = "0.000"
    Next A
    
Next i

RANGE("H6").Select
       
Application.ScreenUpdating = True

End Sub

Answer 1

请试试下一个代码。它处理内存中的范围，加载数组，并在适当的范围内立即删除其内容。另外，在一个单元格中写入一个值，然后包围它，将它放回并格式化每个单元格需要时间.：

Sub RNGTOX()
   Dim lastcell As Range, row As Range, i As Long, A As Long, B As Long
   Dim prumer As Variant, smodch As Variant, LR As Long, LC As Long, LCNEW As Long
   Dim ocislovani As Range, sSIDE As Worksheet
        
  If Range("H6").Value = vbNullString Then
    MsgBox "Chybí data."
    Exit Sub
  End If
     
 Set sSIDE = ActiveSheet
 Set lastcell = sSIDE.cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious)

 LR = sSIDE.cells(sSIDE.rows.count, 1).End(xlUp).row
 LC = sSIDE.cells(6, sSIDE.Columns.count).End(xlToLeft).Column
 B = LC + 1
 LCNEW = sSIDE.Range("B2").Value + 7

If LCNEW <= LC Then
    MsgBox "Pocet už je dosažený. Není treba dopocítávat."
    Exit Sub
End If

 'ocislovani souboru
 Set ocislovani = sSIDE.Range(sSIDE.cells(5, 8), sSIDE.cells(5, LCNEW))
 ocislovani.Value = Evaluate("TRANSPOSE(ROW(1:" & LCNEW & "))")

 Dim rng As Range, arr
 Set rng = sSIDE.Range(sSIDE.cells(6, 8), sSIDE.cells(LR, LC))

 ReDim arr(1 To rng.rows.count, 1 To LCNEW - B + 1) 'redim the array to keep the processed values
 For i = 1 To rng.rows.count
    
    prumer = Application.Average(rng.rows(i))
    smodch = Application.StDev(rng.rows(i))
    
    For A = 1 To UBound(arr, 2)  'LCNEW
       arr(i, A) = Round(Application.Norm_Inv(Rnd(), prumer, smodch), 3) 'load the array (working in memory)
    Next A
 Next i

  'drop the array content, at once:
  With sSIDE.cells(6, B).Resize(UBound(arr), UBound(arr, 2))
        .Value = arr
        .NumberFormat = "0.000"
  End With
 
 Range("H6").Select
 MsgBox "Ready..."
End Sub

代码没有经过测试，没有适当的环境，但是(如果我正确理解了您的代码逻辑)，它应该可以工作。

请测试并发送一些反馈。