Excel版ゴンペルツ松井計算機

 

Excel版ゴンペルツ松井計算機のプログラム(VBAマクロ)を公開します。

電カルのエクセルに以下のプログラムを手入力して移植する事も可能です。

Sub 入力()

If ActiveSheet.ChartObjects.Count = 1 Then ActiveSheet.ChartObjects(1).Delete

Range("K:L").ClearContents

   t0 = Range("C4").Value

    A = Range("D4").Value

   t1 = Range("C5").Value

   B = Range("D5").Value

   t2 = Range("C6").Value

    C = Range("D6").Value

    t3 = Range("C7").Value

    D = Range("D7").Value

    tx = Range("C10").Value

    vy = Range("D10").Value

   Dim yBoundary As Double

   Dim myflag As Integer

   Dim B2upper As Double

   Dim B2lower As Double

   Dim B2 As Double

   B2upper = (A + C) / 2

   B2lower = C

   B2 = (B2upper + B2lower) / 2

   xBoundary = 0

   ftx = 0

   secondSlope = 0

   Intercept = 0

   vytime = 0

  

   If t0 >= t1 Or t1 >= t2 Then

        MsgBox "Please change time as t0 < t1 <t2.": Exit Sub

    End If

    abslope = (B - A) / (t1 - t0)

    bcslope = (C - B) / (t2 - t1)

    acslope = (C - A) / (t2 - t0)

    cdslope = (D - C) / (t3 - t2)

    If abslope * bcslope <= 0 Then

        MsgBox "Please change values.  Because plus-to-minus or minus-to-plus slope is not suitable.": Exit Sub

    End If

    If abslope > bcslope Or abslope > 0 Then

        MsgBox "Slope AB should be steeper than slope BC.": Exit Sub

    End If

   For i = 0 To 100

            m = (A * C - B2 ^ 2) / (A - 2 * B2 + C)

            k = -1 / ((t2 - t0) / 2) * Log((B2 - C) / (A - B2))

            Bx = m + (A - m) * Exp(-k * (t1 - t0))

            If Bx = B Then Exit For

            If B > Bx Then B2lower = B2

            If B < Bx Then B2upper = B2

            B2 = (B2upper + B2lower) / 2

    Next i

            A0 = m + (A - m) * Exp(-k * (-t0))

            d0 = k * (A0 - m)

    If bcslope > cdslope Then myflag = 0

    If bcslope <= cdslope And cdslope < -k * (C - m) Then myflag = 1

    If cdslope >= -k * (C - m) And D <= m + (A0 - m) * Exp(-k * t3) Then myflag = 2

    If D > m + (A0 - m) * Exp(-k * t3) Then myflag = 3

    If Len(t3) = 0 Or Len(D) = 0 Then myflag = 0

    If Len(t3) > 0 Then

            optimalupper = m + (A0 - m) * Exp(-k * t3)

            optimallower = (B - C) / (t1 - t2) * t3 + (C * t1 - B * t2) / (t1 - t2)

    End If

            Range("J13").Value = optimalupper

            Range("J14").Value = optimallower

    If D > 0 Then

        If D > optimalupper Or D <= optimallower Then

        MsgBox "D値を下記の上限と下限を参考にして変更してください": Exit Sub

        End If

    End If

    If myflag = 1 Then

          C2lower = m + (A0 - m) * Exp(-k * (2 * t1 - t0))

          C2upper = B

          C2 = (C2upper + C2lower) / 2

            For i = 0 To 100

                m2 = (A * C2 - B ^ 2) / (A - 2 * B + C2)

                k2 = -1 / (t1 - t0) * Log((B - C2) / (A - B))

               yBoundary = m2 - cdslope / k2

                xBoundary = -(1 / k2) * Log((yBoundary - m2) / (A0 - m2))

                X2 = (yBoundary * t2 - yBoundary * t3 - D * t2 + C * t3) / (C - D)

                If xBoundary = X2 Then Exit For

                If xBoundary < X2 Then C2lower = C2

                If xBoundary > X2 Then C2upper = C2

                C2 = (C2upper + C2lower) / 2

            Next i

            secondSlope = -k2 * (yBoundary - m2)

      End If

      If myflag = 2 Then

                YgeUpper = C

                YgeLower = m + (A0 - m) * Exp(-k * t3)

                yBoundary = (YgeUpper + YgeLower) / 2

            For i = 0 To 100

                xBoundary = -1 / k * Log((yBoundary - m) / (A0 - m))

                secondSlope = -k * (yBoundary - m)

                YD = -k * (yBoundary - m) * t3 + yBoundary - secondSlope * xBoundary

                    If YD = D Then Exit For

                    If YD < D Then YgeUpper = yBoundary

                    If YD > D Then YgeLower = yBoundary

                yBoundary = (YgeUpper + YgeLower) / 2

           Next i

            m2 = m

            k2 = k

        End If

                A0 = m2 + (A - m2) * Exp(-k2 * (-t0))

               d2 = k2 * (A0 - m2)

               Intercept = yBoundary - secondSlope * xBoundary

        If Len(t3) = 0 Or Len(D) = 0 Then

            m2 = m

            k2 = k

            d2 = d0

        End If

            If myflag < 3 And Abs(secondSlope) > 0 Then

               vytime = (vy - Intercept) / secondSlope

            End If

        If vy > yBoundary Then

            vytime = -1 / k2 * Log((vy - m2) / (A0 - m2))

        End If

        If myflag < 1 Or myflag > 2 Then

            k2 = k

            d2 = d0

            m2 = m

        End If

        If tx <= xBoundary Or xBoundary = 0 Then

        ftx = m2 + (A0 - m2) * Exp(-k2 * tx)

        End If

        If tx > xBoundary Then ftx = secondSlope * tx + Intercept

        If Len(t3) = 0 Then

        yBoundary = 0

        ftx = m2 + (A0 - m2) * Exp(-k2 * tx)

        End If

        If Len(tx) = 0 Then

        ftx = 0

        End If

        If Len(vy) = 0 Then

        vytime = 0

        End If

        Range("D12").Value = k2

            Range("D13").Value = -d2

            Range("D14").Value = m2

            Range("D15").Value = yBoundary

            Range("D21").Value = m2

            If (A0 - m) > 0 Then Range("E21").Value = "+" Else Range("E21").Value = "-"

            Range("F21").Value = Abs(A0 - m2)

            Range("H21").Value = -k2

            Range("D23").Value = secondSlope

            Range("F23").Value = Intercept

            Range("D17").Value = ftx

            Range("D18").Value = vytime

            If t2 > t3 Then tmax = t2

            If t3 > tx Then tmax = t3

            If tx >= t3 Then tmax = tx

            myCount = 0

            If xBoundary > 0 Then

            For tn = 0 To tmax

                Cells(tn + 2, 11) = tn

                myCount = myCount + 1

                    If tn < xBoundary Then Cells(tn + 2, 12) = m2 + (A0 - m2) * Exp(-k2 * tn)

                    If tn >= xBoundary Then Exit For

            Next tn

            Cells(tn + 2, 12) = secondSlope * tmax + Intercept

            Cells(tn + 2, 11) = tmax

            End If

            If xBoundary = 0 Then

            For tn = 0 To tmax

                Cells(tn + 2, 11) = tn

                    Cells(tn + 2, 12) = m2 + (A0 - m2) * Exp(-k2 * tn)

                    myCount = myCount + 1

            Next tn

            End If

            Range("I17").Value = tmax

          Set trange = Worksheets("Sheet1").Range(Cells(2, 11), Cells(myCount + 1, 12))

            Charts.Add

                ActiveChart.ChartType = xlXYScatterLines

                ActiveChart.SetSourceData Source:=trange, PlotBy:=xlColumns

                ActiveChart.Location Where:=xlLocationAsObject, Name:="Sheet1"

                ActiveChart.HasLegend = False

                ActiveChart.Axes(xlValue, xlPrimary).HasTitle = True

                ActiveChart.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "HCV-TaqMan"

                ActiveChart.Axes(xlValue, xlPrimary).AxisTitle.AutoScaleFont = False

                ActiveChart.Axes(xlCategory, xlPrimary).HasTitle = True

                ActiveChart.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "time"

                ActiveChart.Axes(xlCategory, xlPrimary).AxisTitle.AutoScaleFont = False

                ActiveChart.PlotArea.Interior.ColorIndex = 2

                ActiveChart.Axes(xlValue).MajorGridlines.Delete

                ActiveSheet.ChartObjects(1).Top = 50

                ActiveSheet.ChartObjects(1).Width = 350

                ActiveSheet.ChartObjects(1).Height = 350

                ActiveSheet.ChartObjects(1).Left = 750

End Sub