Master3’s blog

LaTeXやExcelVBAなどの作例集

ExcelVBA作例7(UV-Vis:吸光度→濃度)

  • 今回は、前回取得したUV-Vis検量線のデータを読み込んで、新しく測定した未知濃度のデータで濃度と最大吸収波長を計算するマクロを紹介いたします。
  • 前回紹介したマクロで検量線を取得したファイルを用意する必要があります

    master3.hatenablog.com

    f:id:Master3:20220324210224p:plain

    ついでにスペクトルも書いてくれます
  • 下に示した生データをメモ帳で保存してみてください。左端が波長です。Excelで開いたときに、A列の二行目以降にデータがないとうまく動きません。

 

[http://:title]

 

  • つぎに、生データをエクセルで開きます 

f:id:Master3:20220324203904p:plain

プログラムから開く→Excel
  • 次に、マクロを実行します

Option Explicit
Sub 吸着等温線()
    Dim C存在 As Boolean
    C存在 = False
    Dim シート As Worksheet
    For Each シート In Worksheets
        If シート.Name = "吸着等温線" Then
            C存在 = True
        End If
    Next
    
    
    Worksheets(1).Select
    
    Dim i As Integer
    i = Range("A23").CurrentRegion(Range("A23").CurrentRegion.Count).Column
    
    Worksheets(1).Select
    Range("A2").Select
    Dim 回数 As Integer
    回数 = 1
    Do While ActiveCell.Value = ""
        ActiveCell.Offset(1).Select
        If 回数 > 100 Then
            Exit Do
        End If
        回数 = 回数 + 1
    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
    
    
    Dim FolderPath, FilePath, FileName
    
    With Application.FileDialog(msoFileDialogOpen)
        .InitialFileName = ActiveWorkbook.Path
        .FilterIndex = 2
        If .Show = -1 Then
            .Execute
        Else
            GoTo L1
        End If
    End With
    Workbooks(1).Activate
    If C存在 = True Then
        Application.DisplayAlerts = False
        Worksheets("吸着等温線").Delete
        Application.DisplayAlerts = True
        C存在 = False
    End If
    If C存在 = False Then
        Worksheets.Add after:=Worksheets(1)
        Worksheets(2).Name = "吸着等温線"
    End If
    
    Worksheets(1).Select
    Range("A23").Select

    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("A17").Value = "初濃度"
    Range("A16").Value = "測定濃度"
    Range("A15").Value = "吸着量[mol/L]"

    
    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

    Worksheets(1).Select
    列番号 = 2
    For 列番号 = 2 To i
        If Cells(17, 列番号).Value = "" Then
            Cells(17, 列番号).Value = Workbooks(2).Worksheets(1).Cells(17, 列番号).Value
            Workbooks(1).Activate
        End If
    Next
    列番号 = 2
    For 列番号 = 2 To i
        If Cells(19, 列番号).Value = "" Then
            Cells(19, 列番号).Value = Workbooks(2).Worksheets(1).Cells(19, 列番号).Value
            Workbooks(1).Activate
        End If
    Next
    Workbooks(1).Activate
    Worksheets(2).Select
    Range("M4").Value = Workbooks(2).Sheets(2).Range("M4").Value '傾きの値を取得
    Workbooks(1).Activate
    Worksheets(2).Select
    Range("O5").Value = Workbooks(2).Sheets(2).Range("O5").Value '切片の値を取得
    Workbooks(1).Activate
    Worksheets(1).Select
    Range("C1").Value = Workbooks(2).Sheets(1).Range("A1").Value 'Day0の日時を取得
    Workbooks(1).Activate
    Worksheets(2).Select
    Range("N5").Value = Workbooks(2).Sheets(2).Range("N3").Value '切片の符号を取得
    Workbooks(2).Activate
    ActiveWorkbook.Close
    GoTo L1
     
L1:
    Worksheets(2).Select
    Range("O6").Value = Range("N5").Value & Range("O5").Value
    
    列番号 = 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
    
    列番号 = 2
    For 列番号 = 2 To i '測定濃度
        Cells(16, 列番号).Value = (Cells(18, 列番号).Value - Range("O6").Value) / Range("M4").Value
    Next
    
    列番号 = 2
    For 列番号 = 2 To i '吸着量[mol/L]
        Cells(15, 列番号).Value = (Cells(17, 列番号).Value - Cells(16, 列番号).Value)
    Next
    
    列番号 = 2 '初濃度
    For 列番号 = 2 To i
        Cells(14, 列番号).Value = Cells(17, 列番号).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
    With ActiveSheet.Shapes.AddChart _
     (xlXYScatter, 20, 40).Chart
     .SetSourceData _
      Range(Cells(14, 1), Cells(15, 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 .Axes(xlValue, 1).TickLabels
            .Font.Color = RGB(0, 0, 0) '文字色
            .Font.Size = 12 'サイズ
            .NumberFormatLocal = "0.000" '表示形式
        End With
        With .Axes(xlValue)
            .HasTitle = True
            .AxisTitle.Text = "吸着量"
            .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

    存在 = 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
    Worksheets(1).Select
    Range("E1").Value = Range("A1").Value - Range("C1").Value
    Range("F1").Value = "日後"
    Range("A1").Select
    MsgBox "!注意! 初濃度と希釈倍率が空欄の場合には、Day0の値を代入しています"
End Sub

 

  • 前回紹介した、検量線のマクロを実行したExcelファイルを選択します

f:id:Master3:20220324204644p:plain

うまくいけば、このようなメッセージボックスが表示されます
  • Excel画面はこのようになります

    黄色い蛍光ペンのラインの二行目は、それぞれの列のデータの希釈倍率になります。
  • ここには検量線の時の希釈倍率のデータがコピペされているので、ただしい希釈倍率に書き直します。
  • 再び同じマクロを実行します

f:id:Master3:20220324205501p:plain

二回目は、ファイルを選択せずにキャンセルを二回押します
  • メッセージボックスが表示されたら、OKを押します。

吸着等温線シートの16行目に、測定濃度
20行目に最大吸収波長が表示されます