ExcelVBA作例7(UV-Vis:吸光度→濃度)
- 今回は、前回取得したUV-Vis検量線のデータを読み込んで、新しく測定した未知濃度のデータで濃度と最大吸収波長を計算するマクロを紹介いたします。
- 前回紹介したマクロで検量線を取得したファイルを用意する必要があります
- 下に示した生データをメモ帳で保存してみてください。左端が波長です。Excelで開いたときに、A列の二行目以降にデータがないとうまく動きません。
[http://:title]
- つぎに、生データをエクセルで開きます
- 次に、マクロを実行します
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
.ChartArea.Format.Fill.Visible = False
.PlotArea.Format.Fill.Visible = False
.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
-
黄色い蛍光ペンのラインの二行目は、それぞれの列のデータの希釈倍率になります。 - ここには検量線の時の希釈倍率のデータがコピペされているので、ただしい希釈倍率に書き直します。
- 再び同じマクロを実行します
- メッセージボックスが表示されたら、OKを押します。
- 以上です。最後までお読みいただきありがとうございます!