Generate random number only to 3 digits with Norm_inv OR ptimize the function-CodePudding

I wrote a macro for generate random number from sample. The RNG core is:

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

It takes a row, calculate average and stdev and then do the stuff.

But on my computer it runs very quick (like 5-10 sec for 80 rows with 10 numbers and calculating 100 more randomized) - and on older computer it runs like 5 minutes! Can I somehow calculete norm inv only to 3 digits? Or optimalize it more?

The whole code is:

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

CodePudding user response：

Please, try the next code. It processes the range in memory, loading an array and its content is dropped at once in the appropriate range. Also, writing a value in a cell then round it, place it back and format each cell takes time...:

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
    'Set row = rng.rows(i) ' Range(cells(i, 8), cells(i, LC))
    
    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

The code is not tested, not having an appropriate environment, but (if I correctly understood your code logic) it should work.

Please, test it and send some feedback.