分子量計算－エクセルで

分子量の計算は、原子量さえ分かれば簡単なことなのですが、いちいち原子量を調べるのも面倒くさいし、ネットには簡単に計算できるページもあるのですが、いちいちそこへ行くのも面倒くさいものです。

手元に置いて使えるものが、なかなか見つかりません。

そこで、エクセルで分子量計算器を作りました。

日本化学会のおかげです
結果も保存できる
原子量表、周期表も付いている
分子式から元素記号と個数を取り出すマクロ
ファイルのダウンロード
1. moleweight
2. マクロ有効化の手順

日本化学会のおかげです

原子量のデータは、日本化学会のPDFファイルを使わせてもらいました。そこからデータを取り出し、「VLOOKUP」関数を使って、計算する、というものです。

分子式をB２セルに入れて、「計算」ボタンをクリック。元素記号と個数が入ります。原子番号、元素名、原子量は、「VLOOKUP」関数を使って取得します。

結果も保存できる

計算結果は、必要があれば保存しておけます。

一応１００行までです。多くなりすぎたら、空にしてください。途中を消去したりすると、次がうまく書き込めません。空白でない行数を調べて、その次に書き込んでいるからです。消去するなら、下の方から消していってください。

原子量表、周期表も付いている

PDFファイルから原子量表を、表にして取り出すのに、少し苦労しました。なので、その原子量表はワークシートとして入れています。というより、「VLOOKUP」のために必要なのですが。

何かアイデアがあれば、他の目的にも使えるかと思います。

ついでに周期表も、画像なのですが、入っています。あれば便利ですよね。

分子式から元素記号と個数を取り出すマクロ

上の画像では隠れていますが、分子量と保存箱の間にあるセルが非表示になっています。分子式が全角で入力されても、半角の式を得られるように、ということと、保存箱に納める時に、一番最初の空白行番号を得て、そこに保存していくためです。

マクロは、次のようになっています。お読みになって、納得されましたら、そして、使ってみるか、と思われましたら、ダウンロードして使ってください。なお、マクロコードは、お好きなように改変してくださって結構です。もっとうまいやり方があると思います。

Attribute VB_Name = "Module1"
Option Explicit

Const CAPTLETTER = 0
Const SMALLLETTER = 1
Const NUMLETTER = 2

Dim fmarray(9, 1) As String

Sub ValueSet()
    Dim fmstr As String
    Dim n, items, r, numc As Integer
    
    Erase fmarray
    fmstr = CheckFormula
    If fmstr = "" Then
        Exit Sub
    End If
    items = SetArray(fmstr)
    Range("element").ClearContents
    Range("number").ClearContents
    r = Range("element").Row
    numc = Range("number").Column
    For n = 0 To items - 1
        Cells(r + n, 1).Value = fmarray(n, 0)
        Cells(r + n, numc).Value = fmarray(n, 1)
    Next n
    ErrorCheck
End Sub
Private Sub ErrorCheck()
    Dim r, n As Integer
    
    n = 0
    For r = 4 To 13
        If Cells(r, 1).Value <> "" Then
            If IsError(Cells(r, 2).Value) Then
                n = n + 1
            End If
        End If
    Next r
    If n > 0 Then
        MsgBox ("式に誤りがあるようです。計算できません。" & n & "個の元素。")
    End If
End Sub
Private Function CheckFormula() As String
    Dim fmstr, tempstr, templetter As String
    Dim n, letterkind, prevletterkind As Integer
    
    CheckFormula = ""
    fmstr = Range("fmcell").Value
    tempstr = ""
    prevletterkind = -1
    For n = 0 To Len(fmstr) - 1
        templetter = Mid(fmstr, n + 1, 1)
        letterkind = CheckCapNum(templetter)
        If letterkind < 0 Then
            MsgBox ("式に誤りがあります。英文字、数字だけで表してください。")
            Exit Function
        End If
        If n = 0 And letterkind > CAPTLETTER Then
            MsgBox ("式に誤りがあります。最初は英大文字で始めてください。")
            Exit Function
        End If
        If letterkind = CAPTLETTER Then '大文字（元素記号の始まり）の場合
            If n = 0 Then
                tempstr = templetter
            Else
                Select Case prevletterkind 'その前の文字が
                    Case CAPTLETTER, SMALLLETTER '元素記号の直前に数字がなければ1を加える
                        tempstr = tempstr & "1" & templetter
                    Case NUMLETTER '数字だとそのままセット
                        tempstr = tempstr & templetter
                End Select
            End If
        Else '元素記号の始まりでなければそのままセット
            tempstr = tempstr & templetter
        End If
        prevletterkind = letterkind
    Next n
    CheckFormula = tempstr
End Function
Private Function SetArray(fmstr As String) As Integer
    Dim n, m, s, num As Integer
    Dim templetter As String
    
    m = 0
    For n = 0 To Len(fmstr) - 1
        templetter = Mid(fmstr, n + 1, 1)
        s = CheckCapNum(templetter)
        If s = NUMLETTER Then
            num = num + 1
            If num = 1 Then '数字1つ目
                fmarray(m, 1) = fmarray(m, 1) & templetter
                m = m + 1
            Else '数字２つ目以降
                fmarray(m - 1, 1) = fmarray(m - 1, 1) & templetter
            End If
        Else
            fmarray(m, 0) = fmarray(m, 0) & templetter
            num = 0
        End If
    Next n
    SetArray = m
End Function
Private Function CheckCapNum(letter As String) As Integer
    Dim ccn As Integer
    
    ccn = -1
    Select Case Asc(letter)
        Case 65 To 90 '大文字
            ccn = CAPTLETTER
        Case 97 To 122 '小文字
            ccn = SMALLLETTER
        Case 48 To 57 '数字
            ccn = NUMLETTER
    End Select
    CheckCapNum = ccn
End Function
Sub CopyResult()
    Dim c, nr As Integer
    
    c = Range("saveresult").Column
    nr = Range("newrow").Value
    Cells(nr, c).Value = Range("B1").Value
    Cells(nr, c + 1).Value = Range("F1").Value
End Sub
Sub ClearSaved()
     Range("saveresult").ClearContents
End Sub

早速、Private Function SetArray(fmstr As String) As Integer　の所でバグがありました。ごめんなさい。ここを訂正すると共に、ダウンロード版についても訂正しておきます。（こんなことでは困りますね）　バグが他にもありましたら、適当に修正してください。こちらで分かれば、すぐ直すようにしますが。(2022/9/16)