ExcelVBA作例6（UV-Vis検量線）

• 今回は、既知濃度の紫外可視吸収スペクトルの波長と吸光度のデータから、検量線の式を取得するマクロをご紹介いたします。

  

  検量線

ついでにスペクトルも書いてくれます

生データはこんな感じ

左端が波長です。Excelで開いたときに、A列の二行目以降にデータがないとうまく動きません。まずはこの生データをメモ帳で開くと、上のようになります↓

[http://:title]

• これをエクセルで開きます

  

  プログラムから開く→Excel

• 次に、マクロを実行します

Option Explicit
Sub 検量線()
    Dim C存在 As Boolean
    C存在 = False
    Dim シート As Worksheet
    For Each シート In Worksheets
        If シート.Name = "Calibration" Then
            C存在 = True
        End If
    Next
    If C存在 = True Then
        Application.DisplayAlerts = False
        Worksheets("Calibration").Delete
        Application.DisplayAlerts = True
        C存在 = False
    End If
    If C存在 = False Then
        Worksheets.Add after:=Worksheets(1)
        Worksheets(2).Name = "Calibration"
    End If
    Worksheets(1).Select
    Range("A2").Select
    Do While ActiveCell.Value = ""
        ActiveCell.Offset(1).Select
    Loop
    ActiveCell.CurrentRegion.Select
    Range(Selection, Selection.End(xlToRight)).Select '1-(b)
    Range(Selection, Selection.End(xlDown)).Select
    Dim 生データ As Range
    Set 生データ = Selection
    Selection.Cut
    Range("A23").Select                              '2-(c)
    ActiveSheet.Paste
    ActiveCell.CurrentRegion.Select
    Selection.Copy
    Worksheets(2).Select
    Range("A23").Select                              '2-(c)
    ActiveSheet.Paste                                 '2-(d)
    Range("B21").Formula = "=MAX(B24:B" & Range("A23").CurrentRegion(Range("A23").CurrentRegion.Count).Row & ")"
    Range("C2").Value = Range("A23").CurrentRegion(Range("A23").CurrentRegion.Count).Row
    Range("C1").Value = "最終行"
    Range("D1").Value = "最終列"
    Range("D2").Value = Range("A23").CurrentRegion(Range("A23").CurrentRegion.Count).Column
    Range("A21").Value = "最大吸光度"
    Range("A20").Value = "最大波長"
    Range("A19").Value = "希釈倍率(要入力)"
    Range("A18").Value = "希釈倍率×MAX"
    Range("B16").Value = "濃度（要入力）"
    Dim i As Integer
    i = Range("A23").CurrentRegion(Range("A23").CurrentRegion.Count).Column
    Dim 最終行 As Integer
    最終行 = Range("A23").CurrentRegion(Range("A23").CurrentRegion.Count).Row
    Dim 列番号 As Integer
    Dim 該当セル As Range
    Dim 行番号 As Integer
    行番号 = 24
    For 列番号 = 2 To i
        Cells(21, 列番号).FormulaR1C1 = "=MAX(R[3]C:R[" & 最終行 - 21 & "]C)"
        行番号 = 24
            Do While Cells(行番号, 列番号).Value <> Cells(21, 列番号).Value
                行番号 = 行番号 + 1
            Loop
        Cells(20, 列番号).Value = Cells(行番号, 1)
    Next
    
    Worksheets(1).Select
    Range(Cells(17, 2), Cells(17, i)).Interior.Color = vbYellow
    Range(Cells(19, 2), Cells(19, i)).Interior.Color = vbYellow
    Worksheets(2).Select
    Range(Cells(17, 2), Cells(17, i)).Interior.Color = vbYellow
    Range(Cells(19, 2), Cells(19, i)).Interior.Color = vbYellow
    
    列番号 = 2
    For 列番号 = 2 To i
        Cells(19, 列番号).Value = Worksheets(1).Cells(19, 列番号).Value
        Worksheets(2).Select
    Next
    列番号 = 2
    For 列番号 = 2 To i
        Cells(17, 列番号).Value = Worksheets(1).Cells(17, 列番号).Value
        Worksheets(2).Select
    Next
    
    列番号 = 2
    For 列番号 = 2 To i
        Cells(18, 列番号).Value = Cells(19, 列番号).Value * Cells(21, 列番号).Value
    Next
    
    Worksheets(1).Select
    On Error GoTo error_check: 'エラートラップ設定
    Range(Cells(17, 2), Cells(17, i)).SpecialCells(xlCellTypeBlanks) = "濃度"
    Range(Cells(19, 2), Cells(19, i)).SpecialCells(xlCellTypeBlanks) = "希釈倍率"
    Exit Sub: '正常終了時はここでルーチン終了

error_check:         'エラートラップ(該当するセルが見つかりません。ならば無視して続けさせる)
        If Err.Number = 1004 Then On Error Resume Next
    Worksheets(2).Select
    
    Dim 存在 As Boolean
    存在 = False
    Range("K2:Q5").Clear
    With ActiveSheet.Shapes.AddChart _
     (xlXYScatter, 20, 40).Chart
     .SetSourceData _
      Range(Cells(17, 1), Cells(18, i))
     .SeriesCollection(1).Trendlines.Add _
        (Type:=xlLinear, Forward:=0, Backward:=0, DisplayEquation:=True, DisplayRSquared:=True).Select
    .HasTitle = True
    .ChartTitle.Text = "検量線"
    .ChartTitle.Font.Size = 11
        With .SeriesCollection(1).Trendlines(1).DataLabel
            Range("K2").Value = .Text
        End With
        With .Axes(xlValue, 1).TickLabels
            .Font.Color = RGB(0, 0, 0) '文字色
            .Font.Size = 12 'サイズ
            .NumberFormatLocal = "#" '表示形式
        End With
        With .Axes(xlValue)
            .HasTitle = True
            .AxisTitle.Text = "希釈倍率×MAX"
            .AxisTitle.Orientation = xlVertical
            .MajorTickMark = xlInside '主目盛内側
            .MajorGridlines.Delete '目盛線消去
            .MinorTickMark = xlInside '補助目盛内側
            With .Format.Line
                .Visible = msoTrue
                .ForeColor.ObjectThemeColor = msoThemeColorText1
                .ForeColor.TintAndShade = 0
                .ForeColor.Brightness = 0
                .Transparency = 0
            End With
        End With
        With .Axes(xlCategory).TickLabels
            .Font.Color = RGB(0, 0, 0) '文字色
            .Font.Size = 12 'サイズ
            .NumberFormatLocal = "0.0" '表示形式
        End With
        With .Axes(xlCategory)
            .HasTitle = True
            .AxisTitle.Text = "濃度"
            .MajorTickMark = xlInside '主目盛内側
            .MinorTickMark = xlInside '補助目盛内側
                With .Format.Line
                    .Visible = msoTrue
                    .ForeColor.ObjectThemeColor = msoThemeColorText1
                    .ForeColor.TintAndShade = 0
                    .ForeColor.Brightness = 0
                    .Transparency = 0
                End With
        End With
        .HasLegend = False                                   '---凡例を非表示
    End With
    ActiveChart.PlotArea.Select
    With Selection.Format.Line
        .Visible = msoTrue
        .ForeColor.ObjectThemeColor = msoThemeColorText1
        .ForeColor.TintAndShade = 0
        .ForeColor.Brightness = 0
        .Transparency = 0
    End With
    Dim srcRange As Range
    Dim destRange As Range
    
    '分割したいデータが設定されているセルを指定
    Set srcRange = Range("K2")
    '分割後のデータの設定を開始するセルを指定
    Set destRange = Range("K3")
    If Range("K2").Value <> "" Then
        '「スペース」で分割
        srcRange.TextToColumns Destination:=destRange, Space:=True
        Dim v
        v = Split(Range("O3"), "R")
        Range("O4").Value = v(0)
        Dim a
        a = Split(Range("M3"), "x")
        Range("M4").Value = a(0)
        Range("O5").Value = Val(Range("O4"))
    End If
    Worksheets(2).Select
    Range("O6").Value = Range("N3").Value & Range("O5").Value
    列番号 = 2
    For 列番号 = 2 To i '測定濃度
        Cells(16, 列番号).Value = (Cells(18, 列番号).Value - Range("O6").Value) / Range("M4").Value
    Next

    存在 = False
    For Each シート In Worksheets
        If シート.Name = "spectrum" Then
            存在 = True
        End If
    Next
    If 存在 = True Then
        Application.DisplayAlerts = False
        Worksheets("spectrum").Delete
        Application.DisplayAlerts = True
        存在 = False
    End If
    If 存在 = False Then
        Worksheets.Add after:=Worksheets(2)
        Worksheets(3).Name = "spectrum"
        生データ.Copy Worksheets(3).Range("A23")
        Dim 濃度 As Range
        Worksheets(2).Select
        Set 濃度 = Worksheets(2).Range(Cells(17, 2), Cells(17, i))
        Worksheets(3).Select
        濃度.Copy Worksheets(3).Range(Cells(23, 2), Cells(23, i))
        Worksheets(3).Range("A23").Clear
        With ActiveSheet.Shapes.AddChart _
            (xlLine, 20, 40).Chart
            .SetSourceData _
              Range("A23").CurrentRegion
                With .Axes(xlValue, 1).TickLabels
                    .Font.Color = RGB(0, 0, 0) '文字色
                    .Font.Size = 12 'サイズ
                    .NumberFormatLocal = "0.0" '表示形式
                End With
                With .Axes(xlValue)
                    .MajorTickMark = xlInside '主目盛内側
                    .MinorTickMark = xlInside '補助目盛内側
                    With .Format.Line
                        .Visible = msoTrue
                        .ForeColor.ObjectThemeColor = msoThemeColorText1
                        .ForeColor.TintAndShade = 0
                        .ForeColor.Brightness = 0
                        .Transparency = 0
                    End With
                End With
                With .Axes(xlCategory).TickLabels
                    .Font.Color = RGB(0, 0, 0) '文字色
                    .Font.Size = 12 'サイズ
                    .NumberFormatLocal = "#" '表示形式
                End With
                With .Axes(xlCategory)
                    .HasTitle = True
                    .AxisTitle.Text = "波長"
                    .MajorTickMark = xlInside '主目盛内側
                    .MinorTickMark = xlInside '補助目盛内側
                        With .Format.Line
                            .Visible = msoTrue
                            .ForeColor.ObjectThemeColor = msoThemeColorText1
                            .ForeColor.TintAndShade = 0
                            .ForeColor.Brightness = 0
                            .Transparency = 0
                        End With
                End With
                .HasLegend = True                                   '---凡例を非表示
        End With
        Worksheets(1).Select
    End If
    Range("E1").Value = 0
    MsgBox "完了"
End Sub

• 

  問題なく実行されると、こんな感じ

  
  つぎに、濃度と希釈倍率と書かれたセルに、それぞれの値を代入します

0.01	0.01	0.01	0.05	0.05	0.05	0.1	0.1	0.1	0.2	0.2	0.2	0.4	0.4	0.4
2	2	2	10	10	10	10	10	10	20	20	20	40	40	40

• 

  濃度と希釈倍率を入力

  
  再び、同じマクロを実行します

うまくいけば、このようなメッセージボックスが現れる

Calibrationのシートには検量線が描画される

• 

  ついでにspectrumのシートにスペクトルも書いてくれます

  
  以上です。最後までお読みいただきありがとうございます！

  日経ソフトウエア 2022年5月号 [雑誌]