GRR数据模拟器VBA BUG修复

imjohnson

    本人从网上获得一个GRR数据模拟器（测量系统分析工具），是VBA自动生成一些数据，原本所有数据都应该是小数点3位（0.000）但其中红色区域无法按照规则运行，小数点不能管制到3位。
    本人对VBA不熟悉，哪位大侠能帮忙看看这些程序语句，看哪里能调整的







Sub generateData()
    Application.ScreenUpdating = False
    Range("F22:O30").ClearContents
   
    Dim weishu As Long, fillr As Integer, pn As Double, av_address As String
    Dim ev_wave As Double, ev_drift As Double, av_wave As Double, part_value As Double, wave_spec As Double, av_drift As Double
   
    fillr = 22
    weishu = 1000
    wave_spec = Range("I4") - Range("H4")
    av_address = "F15"
   
'    ev_drift = getRank(Range("F17")) * wave_spec
   
next_appraiser:
   
   
    av_drift = getRank(Range(av_address)) * wave_spec * (1 - Rnd() * 2)
   
    For r = fillr To fillr + 1
        
        For c = 6 To 15
            part_value = Cells(11, c) + av_drift
'            av_wave = wave_spec * (1 - Rnd() * 2) * 0.1
            
        ev_wave = getRank(Range("F17")) * wave_spec * (1 - Rnd() * 2) * 0.8
            pn = part_value + ev_wave + av_wave
            pn = Int(pn * weishu) / weishu
            Cells(r, c) = pn
            If r = fillr + 1 Then
                Cells(r + 1, c) = 3 * part_value - Cells(r, c) - Cells(r - 1, c)
            End If
        Next
    Next
    fillr = fillr + 3
        
    If fillr < 30 Then
        If fillr = 25 Then
            av_address = "I15"
        ElseIf fillr = 28 Then
            av_address = "L15"
        End If
        GoTo next_appraiser:
    End If
    Application.ScreenUpdating = True
End Sub

Function part_random()
    Dim spec As Double, tolerance As Double
    Dim p_rnd As Double, a_rnd As Double
    Dim a_diff As Double, a3_diff As Double, p_diff As Double
   
    spec = Range("F4")
    tolerance = Range("I4") - Range("H4")
    p_rnd = tolerance * (1 - getRank(Range("F6"))) / 2

    For c = 6 To 15
        Cells(11, c) = spec + (Rnd() * 2 - 1) * p_rnd
    Next

End Function

Sub fillToTemplate()

    Application.ScreenUpdating = False
   
    Dim tolerance
    With Worksheets(1)
    tolerance = Range("I4") - Range("H4")
        .Range("I11") = Range("I4")
        .Range("I13") = Range("H4")
    End With
   
    Worksheets(2).Range("F22:O24").Copy
    Worksheets(1).Range("E19").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Worksheets(2).Range("F25:O27").Copy
    Worksheets(1).Range("E25").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Worksheets(2).Range("F28:O30").Copy
    Worksheets(1).Range("E31").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Worksheets(2).Select
   
    Application.ScreenUpdating = True
End Sub
'more star, less rate
Function getRank(ByVal stars As String)
    Dim v As Integer
    v = WorksheetFunction.Match(stars, Range("B:B"), 0)
    getRank = 1 - (v - 1) / 6.2
End Function