Powerpoint VBAを使おう!

Powerpoint VBAやExcelのVBAで遊んでいます。AdobeのScriptにも興味が少し。。

メモ

Excelで図形を作ってOnActionを使ってみようとしていたら,次の記事を見つけました。

Excel VBA を学ぶなら moug モーグ | 即効テクニック | OnActionで実行するプロシージャに引数を渡す


図形にマクロをつけて,引数もつけれると(;´▽`A``

これはいい。

軽くテストしてみました。

Sub test()
    Dim Sht As Worksheet: Set Sht = ActiveSheet
    Dim Rng As Range: Set Rng = Sht.Range("c5:e8")

    Dim c As Range
    For Each c In Rng
        With Sht.Shapes.AddLabel(msoTextOrientationHorizontal, c.Left, c.Top, c.Width, c.Height)
            .Name = c.Address(False, False) & "_BTN"
            .OnAction = "'test2 """ & .Name & """ '"
            '.OnAction = "'test2 ""印刷""'"
        End With
    Next
    
End Sub


Sub test2(Str As String)
    MsgBox Str
End Sub

セルのシングルクリックイベントの代わりに図形をのせているので,各セルのleft,top,width,heightを使って図形を書き,それにOnActionをのっける。

セルのアドレスを捕まえることができるなら,いろいろとやれるのでそのためのものです。

testマクロを動かすと,
f:id:chemiphys:20181116220018p:plain
セルの上に図形をきれいにはりつけます。
無色透明にするなら .Fill.Visible=msoFalse をすればいいのかな。

これを実行すると,そのセルを選んだら(そこに貼り付けられている図形をクリックしたら)
f:id:chemiphys:20181116221039p:plain

このように,ちゃんとアドレスにしたがった値を返せます。

これはきっといいものな気がします。

onActionでマクロを貼り付けられた図形を動かすのはちょっと面倒なので,その点もいい感じ。

シートに貼る形のActiveXのリストボックスが,解像度が変わったり,タブレットで縦横表示が切り替わり続けると容易に表示が崩れたりと役立たずだったので,


リストボックス風なものを自分で実装したりしていました。
それを実現するためのいい手段が手に入った気がします。

追記 さらにメモ

d.hatena.ne.jp

のコメントのところから抜粋

参考にさせて頂き、助かりました。
第二引数の指定方法が分かりましたので、例示しておきます。
Sub AAAA(str1 As String, str2 As String)
.OnAction = "'AAAA ""引数1"", ""引数2""'"

きっといつか使う

さらにさらに追記

まぁこれも面白いわけですが,Powerpointの時もそうでしたが,セルに書く必要ないじゃないか という根本的なところにいきますね。。
セルにこだわらずに,加えた図形群でリストボックスぽいものをやる方法を考えていこう。

トグル入力のコード Excel VBA

ブログ名前詐欺中です。 今取り組んでることのための部品。

キーボードを使わずタブレットだけで作業をする。

複雑なインターフェースは準備できない。 でも簡単な入力方法を実装したい。

いつも思いつくのは,お風呂に入ってるときや,帰宅,出勤時。

考えを変えるタイミングって大事ですね。

さて,とても単純なヤツデス。

Sub クリック入力(Add As String, Min As Long, Max As Long)
    Dim Rng As Range: Set Rng = ActiveSheet.Range(Add)
    Rng.Value = Rng.Value + 1
    If Rng.Value > Max Then Rng.Value = Min
End Sub

Sub Sht1_E5()
    Call クリック入力("e5", 0, 5)
End Sub

Sub Sht1_E6()
    Call クリック入力("e6", 0, 1)
End Sub

(´▽`) '`,、'`,、 ミジカイ

f:id:chemiphys:20181114224804p:plain


私は雑な人間ですが,さすがに,上のSSはわざとちょっとずれてるのをスルーしています。

E5,E6のセル上にボタンにするための透明な図形をのせて,それらに Sht1_E5 Sht1_E6をマクロ登録しています。

動画とらないで大丈夫ですよね。。あまりにも短いコードですから。。

クリックするたびに数値が1ずつ増え,最大値を超えると最小値になるよ,というコードです。

Excelのリスト入力は便利なんですけど,キーボードやマウスが使えない時ってあれってかなりちっちゃい。

その時のためのインターフェースとして考えてみました。明日実装してみよう。。

毎年この時期はデータ処理。。

教員をしていると,入試の時期が必ず来ます。

そろそろ,また今年の分の調整をし始めないといけません。

思えば,様々なアドバイスをいただき始めたのも,データ処理をどうするか,という話の頃から。

とてもありがたいことです。以前とはコードの書き方もけっこう変化しました。

そして,私はいつも同じ付近に考え方を戻して,いろんなことを気分でやるので,今回はある意味ふりだしに戻った感が否めません。

ですが,VBA組める同僚はほとんど出会わない職場ですので,他の人でも見てわかる,とか,自分が中身を忘れてもみればわかる・・・

そのようなものを求めるのもしょうがないのかなぁと思います。

infoment.hatenablog.com

Infomentさんのブログで配列のソートに取り組まれています。

PowerPointでものづくりをするときは否応なしにそっち方向でやっていかないといけないので,とても楽しみに様子を見させてもらってます。

わたしは,とりあえず今年は一時ワークシートを作ってそこで作業する,という方向に戻して考えようということにしました。

Stopでもそのあたりに入れておけば,ソートの途中経過など確認しやすいから,というのもありますね。

とりあえずてきとーに組んだのがこちら。Excel VBAです。

Function ソート(ソース As Variant, ParamArray Keys()) As Variant
    
    Dim Data As Variant, 行数 As Long, 列数 As Long
    If TypeName(ソース) = "Range" Then
        行数 = ソース.Rows.Count
        列数 = ソース.Columns.Count
        Data = ソース.Value
    Else
        行数 = UBound(ソース, 1)
        列数 = UBound(ソース, 2)
        Data = ソース
    End If
    
    Dim TempSht As Worksheet
    Set TempSht = ThisWorkbook.Worksheets.Add
    
    Dim s As Worksheet, No As Long, flg As Boolean
    Do
        No = No + 1
        flg = False
        For Each s In ThisWorkbook.Worksheets
            If s.Name = "作業用一時シート" & Format(No, "00") Then flg = True
        Next
    Loop Until flg = False
    TempSht.Name = "作業用一時シート" & Format(No, "00")

    Dim SObj As Sort, TempRng As Range, i As Long, j As Long
    Set TempRng = TempSht.Range(TempSht.Cells(1, 1), TempSht.Cells(行数, 列数))
    TempRng.Value = Data

    Set SObj = TempSht.Sort
    With SObj
        .SortFields.Clear
        .SetRange TempRng
        .Header = xlYes
        For i = 0 To UBound(Keys) - 1 Step 2
            .SortFields.Add Key:=TempRng.Cells(1, Keys(i)), Order:=Switch(Keys(i + 1) = True, xlAscending, Keys(i + 1) = False, xlDescending)
        Next
        .Apply
    End With
    
    ソート = TempRng.Value
    
    Application.DisplayAlerts = False
        TempSht.Delete
    Application.DisplayAlerts = True
    
    
End Function

Function 抽出(ソース As Variant, flg As Variant, ParamArray Keys()) As Variant
    Dim i As Long, j As Long, k As Long, l As Long, Flg2 As Boolean
    Dim 行数 As Long, 列数 As Long, tmp() As Variant
    
    行数 = UBound(ソース, 1)
    列数 = UBound(ソース, 2)
    
    If flg = True Then
        ReDim tmp(1 To 行数, 1 To UBound(Keys) + 1)
        For i = 1 To UBound(ソース, 1)
            k = 1
            For l = 0 To UBound(Keys)
                tmp(i, k) = ソース(i, Keys(l))
                k = k + 1
            Next l
        Next i
    Else
        ReDim tmp(1 To 行数, 1 To 列数 - UBound(Keys) - 1)
        k = 1
        For j = 1 To UBound(ソース, 2)
            Flg2 = True
            For l = 0 To UBound(Keys)
                If j = Keys(l) Then Flg2 = False
            Next
            If Flg2 = True Then
                For i = 1 To UBound(ソース, 1)
                    tmp(i, k) = ソース(i, j)
                Next
                k = k + 1
            End If
        Next
    End If
    
    抽出 = tmp
End Function

Sub テスト()
    Dim ret As Variant
    ret = 抽出(ソート(Sheet1.Range("a1").CurrentRegion, 8, True, 5, True), True, 5, 6, 7, 9)
    
    Sheet4.Cells(1, 1).Resize(UBound(ret, 1), UBound(ret, 2)).Value = ret
    Stop
End Sub

Sub テスト2()
    Dim a As Variant: a = Sheet1.Range("a1").CurrentRegion.Value
    Dim b As Variant: b = 抽出(a, False, 2, 3)
    Stop
End Sub

自分用メモが主のブログでもありますので,説明とかいろいろと省きまくりなのはスルーしてほしいところです。

一時シートをつくり,そこにデータを放り込んでソートオブジェクトにおまかせ,というやつです。

あと,ソートの結果の一部を利用したり,または,ほとんど利用するんだけど,数列分は消したいという作業をよくやるので,抽出する関数も用意しています。

Sheet1のデータを取り込んで,一部抽出したり,ソート結果をさらに抽出する,という作業を テスト や テスト2
とかでやってみてますが,見た目にはまともに動いてそうでした。。

結局,速いアルゴリズムが優れたソートを自分はあまり実装できず,できてバブルソートだったりするので,

ExcelならSortオブジェクト使い倒してしまえ,という気分で作ったものです。

いくつキー与えてもやってくれるし,このマクロ組んでたら,Sortにcustomorderが使えるというのに今更ながらに知って驚いたり,

やっぱりいろいろと気楽にやってみるもんだなぁと思ったところです。。


--
わたしがいる学校ではそろそろ文化祭。

同僚に突然仕事を振られて,準備期間ほんのちょっとなのに 販売で使うシステムを組まされたりしています。

かなり以前に,小さなテキストメモみたいなものを吐き出して共通に見れるフォルダに放り込み,それをデータとして使う,,というシステムを作ったことがありました。

きちんとルール作りをすれば,データはその1KB程度のテキストがたくさん存在するだけであり,Excelが固まってもデータはほとんど消えることなく,

システムも小さくて済む。とても気楽に多人数でデータを扱えるシステムができている気がしています。

まさかこんなところで日の目を見るとは思わないものづくりでしたが,いつどんなものが役に立つかわからないものだなぁと思う。

思いつきは役に立とうが立つまいが一度は形にして,蓄積していけばいつか時間がないときにささっと対応できるなぁ,と2年ほど前の自分をほめつつ,

極めて短い準備期間なので,不具合をとても不安にも思いつつ作業しているところです。。

ひと段落しています。(VBAコード一切ありません)

とりあえず,作った教材を紹介する,という機会が終わりました。

仕事で人にものを説明することを日々やっている割に,やはり緊張するものですね。

また,PowerPoint2016のノートPCとPowerPoint2013のタブレットで動作確認をし,さらに直前に,

説明する電子黒板と同じ状態であろう,隣の部屋の電子黒板で動くことを確認していたのに,

実際説明するとき(PowerPoint2013でした),途中でマクロが止まってΣ(・ω・ノ)ノ!びっくりしました。

こういうとこは,さすが自分だな・・(;´▽`A``と思う次第。。

疑問なのは,普段スライドショーの完遂が優先され,コードエラーを直接吐かず沈黙するPowerPoint

エラーを吐いて止まったこと。。

どういう状態だったのか興味があります。確かめようはありませんが。。

いい経験ですね。やはり,動かす機械で確認をとっておかないといけないです。

一部,思い通りにいかなかったとはいえ,その部分はどちらかといえば枝葉の部分で主幹部分ではなかったので,

軽くスルーしてしまいました。

自分の適当さをそこでも感じたところです。

・・・

終わったし,何かまた何か作ってみよう。何に手を出そうか。。

( ´ー`)フゥー...

有効数字 今度こそ大丈夫??

まだ変なとこありましたので,書き直してみた。

うーん。なんと面倒な。。気にせずやれればいいんですが(;´▽`A`` 固定小数点でやれない数値の扱いって面倒ですね。

できるだけシンプルな方法を今後も考えます。主目的がここじゃないせいで,トライアンドエラーでしかやってない(;´▽`A``

Function 有効数字表示(As Variant,As Long, 指数表示 As Boolean) As String
    Dim Val_ As String, Format_ As String
    If= 1 Then Format_ = "0e-0" Else Format_ = "0." & String(- 1, "0") & "e-0"
    Val_ = Format(CSng(), Format_)
    
    If 指数表示 = True Then
        有効数字表示 = Replace(Val_, "e", "×10^")
    Else
        Dim 数値部分, 桁部分, tmp, tmp2, tmp3, tmp4
        数値部分 = Left(Val_, InStr(Val_, "e") - 1)
        桁部分 = Mid(Val_, InStr(Val_, "e") + 1)
        有効数字表示 = CSng(数値部分 & "e" & 桁部分)
        If= 1 Then Exit Function
        
        If InStr(有効数字表示, "E") = 0 Then
            If InStr(有効数字表示, ".") > 0 Then tmp = Len(有効数字表示) - 1 Else tmp = Len(有効数字表示)
            tmp = Format(CSng(数値部分) / CSng(有効数字表示), "0e-0")
            tmp2 = Replace(数値部分, ".", "")
            tmp3 = Mid(tmp, InStr(tmp, "e") + 1)
            Select Case tmp3
                Case Is = 0
                    有効数字表示 = 数値部分
                Case Is > 0
                    If tmp = 1 Then
                        有効数字表示 = "0." & tmp2
                    Else
                        有効数字表示 = "0." & String(tmp3 - 1, "0") & tmp2
                    End If
                Case Is < 0
                    tmp4 = Len(有効数字表示)
                    If tmp4 <Then
                        有効数字表示 = 有効数字表示 & "." & String(- tmp4, "0")
                    End If
            End Select
            
        End If
        
    End If
End Function

ちまちま確かめていると,間違いに気づかないのでExcelにこのFunctionを放り込んでチェック

f:id:chemiphys:20181103103757p:plain

大丈夫そうだけどなぁ(;´▽`A``

有効数字 修正をはじめてます。

有効数字を処理する部分がまずそうだったので修正中です。

Function 有効数字表示(As Variant,As Long, 指数表示 As Boolean) As String
    Dim Val_ As String, Format_ As String
    If= 1 Then Format_ = "0" Else Format_ = "0." & String(- 1, "0") & "e-0"
    Val_ = Format(CSng(), Format_)
    
    If 指数表示 = True Then
        有効数字表示 = Replace(Val_, "e", "×10^")
    Else
        有効数字表示 = CSng(Left(Val_, InStr(Val_, "e") - 1) & "e" & Mid(Val_, InStr(Val_, "e") + 1))
        
        If InStr(有効数字表示, "E") = 0 Then
            Dim 数値スタート As Long, i As Long, 数値桁 As Long
            For i = 1 To Len(有効数字表示)
                If Mid(有効数字表示, i, 1) <> "0" And Mid(有効数字表示, i, 1) <> "." Then
                    数値スタート = i
                    Exit For
                End If
            Next
            
            数値桁 = Len(有効数字表示) - 数値スタート + 1
            If> 数値桁 Then
                If Len(有効数字表示) = 1 Then 有効数字表示 = 有効数字表示 & "."
                有効数字表示 = 有効数字表示 & String(- 数値桁, "0")
            End If
        End If
    End If
End Function


数値桁 = Len(有効数字表示) - 数値スタート + 1
If 桁 > 数値桁 Then
If Len(有効数字表示) = 1 Then 有効数字表示 = 有効数字表示 & "."
有効数字表示 = 有効数字表示 & String(桁 - 数値桁, "0")
End If

最後当たりのこの辺がうまくいっていません。
考え中。

追記

とりあえず,トライアンドエラーでいじってみました。

フローチャートを書いて根元から考えようとしないヤツですみません(;´▽`A``

Function 有効数字表示(As Variant,As Long, 指数表示 As Boolean) As String
    Dim Val_ As String, Format_ As String
    If= 1 Then Format_ = "0e-0" Else Format_ = "0." & String(- 1, "0") & "e-0"
    Val_ = Format(CSng(), Format_)
    
    If 指数表示 = True Then
        有効数字表示 = Replace(Val_, "e", "×10^")
    Else
        Dim 数値部分, 桁部分, tmp, tmp2
        数値部分 = Left(Val_, InStr(Val_, "e") - 1)
        桁部分 = Mid(Val_, InStr(Val_, "e") + 1)
        有効数字表示 = CSng(数値部分 & "e" & 桁部分)
        If= 1 Then Exit Function
        
        If InStr(有効数字表示, "E") = 0 Then
            If InStr(有効数字表示, ".") > 0 Then tmp = Len(有効数字表示) - 1 Else tmp = Len(有効数字表示)
            tmp = Format(CSng(数値部分) / CSng(有効数字表示), "0e-0")
            tmp = Mid(tmp, InStr(tmp, "e") + 1)
            tmp2 = Replace(数値部分, ".", "")
            Select Case tmp
                Case Is = 0
                    有効数字表示 = 数値部分
                Case Is > 0
                    If tmp = 1 Then
                        有効数字表示 = "0." & tmp2
                    Else
                        有効数字表示 = "0." & String(tmp - 1, "0") & tmp2
                    End If
                Case Is < 0
                    有効数字表示 = Left(tmp2, 1 - CLng(tmp)) & "." & Mid(tmp2, 2 - CLng(tmp))
                    If Right(有効数字表示, 1) = "." Then 有効数字表示 = Left(有効数字表示, Len(有効数字表示) - 1)
            End Select
            
        End If
        
    End If
End Function


イミディエイトウィンドウでいろいろやってみた感じはいけそうなんだけど・・,さすがに何度も間違ったのでまだ疑っています(;´▽`A``

あとあきらかに美しくないので,きちんと統合していこうと思います。

化学反応式の量的関係 とりあえず完了

コードが長いです(;´▽`A``
正規表現を使っているのでMicrosoft VBScript Regular Expressions 5.5への参照設定が必要です。

コードが長すぎるため,最初に書きたいだけ書きます。

新規のプレゼンテーションに標準モジュールを追加し,そこにペタッと下記のコードを貼ります。

問題集作成マクロを実行すると,
f:id:chemiphys:20181029190436p:plain
こんなものが作られます。スライドショーを実行しましょう。

右側に並んでいる緑の番号を押すとその化学反応式が選ばれます。
そしたら,次の画面に移る。

f:id:chemiphys:20181029213253p:plain

5,7,9,11行目の白いセル?のどこかをクリックすると,そこに数値を入れれます。
画面切り替えを止めていないので,押せないところを押さないように気を付けましょう。スライドショーが終わりに向かいます。

マクロでやればよかったんですが,クリックしても画面切り替えしないように設定するといいと思われます。
f:id:chemiphys:20181029213352p:plain

表示を押すと,

f:id:chemiphys:20181029213413p:plain
表が埋まる。

数値は何度でも変えれるので,いろんな数値が試せます。個数の時は 6.0×10^23 なら 6e23 とか入力してください。

ツカレタ。。

マクロが長いせいか,なんにもなくてもパワーポイントが再起動することがあります。

このへんは,変わらないですね。。

どうしてなんでしょう( ´ー`)フゥー...

そうそう,個数はあまり物質量がとんでもない数値にならない程度で許してあげてください(;´▽`A``

全てを指数表示にしたら耐えれますが,今はそのようになっていません。

気体の体積は四捨五入した値がピンと来ない子が多いため,有効数字を他のものと統一していません。

けっこう適当な感じです(;´▽`A``

Const 行数 = 11, 列数 = 6, 行高さ = 49, 列幅 = 160
Const 原子量 = "H,1,C,12,N,14,O,16,Na,23,Mg,24,Al,27,P,31,S,32,K,39,Cl,35.5,Ca,40,Mn,55,Fe,56,Cu,64,Zn,65"
Const NA As Single = 6# * 10 ^ 23
Sub 問題集作成()
    Dim Sld1 As Slide: Set Sld1 = ActivePresentation.Slides(1)
    Sld1.Shapes.Range.Delete
    If ActivePresentation.Slides.Count = 1 Then ActivePresentation.Slides.Add 2, ppLayoutBlank
    Dim 問題テーブル As Table
    
        
    With Sld1.Shapes.AddTable(11, 2)
        .Table.Columns(1).Width = 77
        .Table.Columns(2).Width = 771
        .Name = "問題テーブル"
        Set 問題テーブル = .Table
        Dim i
        For i = 1 To 10
            .Table.Cell(1 + i, 1).Shape.TextFrame.TextRange.Text = i & ")"
            .Table.Rows(i + 1).Height = 46.5
            .Table.Cell(1 + i, 2).Shape.TextFrame.VerticalAnchor = msoAnchorMiddle
        Next
    
        .Table.Cell(2, 2).Shape.TextFrame.TextRange.Text = "N2+3H2→2NH3"
        .Table.Cell(3, 2).Shape.TextFrame.TextRange.Text = "CH4+2O2→CO2+2H2O"
        .Table.Cell(4, 2).Shape.TextFrame.TextRange.Text = "2H2S+SO2→3S+2H2O"
        .Table.Cell(5, 2).Shape.TextFrame.TextRange.Text = "2Al+6HCl→2AlCl3+3H2"
        .Table.Cell(6, 2).Shape.TextFrame.TextRange.Text = "MnO2+4HCl→MnCl2+2H2O+Cl2"
        .Table.Cell(7, 2).Shape.TextFrame.TextRange.Text = "P4O10+6H2O→4H3PO4"
        .Table.Cell(8, 2).Shape.TextFrame.TextRange.Text = "4Al+3O2→2Al2O3"
        .Table.Cell(9, 2).Shape.TextFrame.TextRange.Text = "2KClO3→2KCl+3O2"
        .Table.Cell(10, 2).Shape.TextFrame.TextRange.Text = "C3H8+5O2→3CO2+4H2O"
        .Table.Cell(11, 2).Shape.TextFrame.TextRange.Text = "C2H5OH+3O2→2CO2+3H2O"
        .Left = 24
        .Top = 10
    End With
    For i = 1 To 10
    With Sld1.Shapes.AddLabel(msoTextOrientationHorizontal, 878, 46.5 * i - 6, 44, 44)
        .TextFrame.AutoSize = ppAutoSizeNone
        .TextFrame.TextRange.Text = i
        .TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
        .TextFrame.VerticalAnchor = msoAnchorMiddle
        .Fill.ForeColor.RGB = rgbGreen
        .Name = "変更ボタン " & i
        .ActionSettings(ppMouseClick).Action = ppActionRunMacro
        .ActionSettings(ppMouseClick).Run = "問題変更"
    End With
    Next
    With Sld1.Shapes.AddLabel(msoTextOrientationHorizontal, 878, 0, 44, 44)
        .TextFrame.AutoSize = ppAutoSizeNone
        .TextFrame.TextRange.Text = "編集"
        .TextFrame.TextRange.Font.Color.RGB = rgbBlack
        .TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
        .TextFrame.VerticalAnchor = msoAnchorMiddle
        .Fill.ForeColor.RGB = rgbYellow
        .Name = "問題編集"
        .ActionSettings(ppMouseClick).Action = ppActionRunMacro
        .ActionSettings(ppMouseClick).Run = "問題編集"
    End With
    
    Dim Reg As New RegExp, Matches As MatchCollection
    With Reg
        .Global = True
        .Pattern = "[A-Za-z][0-9]+"
    End With
    Dim j
    For j = 2 To 11
        Set Matches = Reg.Execute(問題テーブル.Cell(j, 2).Shape.TextFrame.TextRange.Text)
        For i = 0 To Matches.Count - 1
            問題テーブル.Cell(j, 2).Shape.TextFrame.TextRange.Characters(Matches(i).FirstIndex + 2, Matches(i).Length - 1).Font.Subscript = True
        Next
    Next
    
End Sub
Sub 問題変更(TShp As Shape)
    
    Dim Sld1 As Slide: Set Sld1 = ActivePresentation.Slides(1)
    Dim Sld2 As Slide: Set Sld2 = ActivePresentation.Slides(2)
    Dim Val(1 To 11, 1 To 6) As String
    
    Dim 化学反応式 As String, n As Long
    n = CLng(Split(TShp.Name)(1)) + 1
    
    化学反応式 = Sld1.Shapes("問題テーブル").Table.Cell(n, 2).Shape.TextFrame.TextRange.Text
    
    Dim Reg As New RegExp
    Dim 係数Matches As MatchCollection, 化合物Matches As MatchCollection   ', 係数抜きMatches As MatchCollection
    With Reg
        .Global = True
        .Pattern = "[\+→]([0-9]*)"
        Set 係数Matches = .Execute("+" & 化学反応式)
        .Pattern = "([0-9]*)([A-Z][a-z]?[A-Za-z0-9]*)"
        Set 化合物Matches = .Execute(化学反応式)
    End With
    
    Call 表作成
    
    Dim 矢印 As String, i As Long, j As Long, 係数 As String
    For i = 0 To 化合物Matches.Count - 1
        Val(1, i + 2) = 化合物Matches(i)
        
        係数 = 化合物Matches(i).SubMatches(0)
        If 係数 = "" Then 係数 = 1
        Val(2, i + 2) = Switch(係数 = "", 1, 係数 <> "", CLng(係数))
        
        Val(3, i + 2) = 式量(化合物Matches(i).SubMatches(1))
        
    Next
    
    For i = 1 To 11
        For j = 2 To 6
            If Val(1, j) = "" Then Sld2.Shapes(i & " " & j).Visible = msoFalse Else Sld2.Shapes(i & " " & j).Visible = msoTrue
        Next
    Next
    
    For i = 1 To 係数Matches.Count - 1 '1スタートは最初無視するため
        矢印 = 矢印 & Left(係数Matches(i), 1)
    Next
    Call 矢印作成(矢印)
    
    Dim k, Matches As MatchCollection
    For j = 2 To 6
        For i = 1 To 3
            Sld2.Shapes(i & " " & j).TextFrame.TextRange.Text = Val(i, j)
        Next
        With Reg
            .Pattern = "[A-Za-z][0-9]+"
            Set Matches = .Execute(Val(1, j))
        End With
        For k = 0 To Matches.Count - 1
            Sld2.Shapes(1 & " " & j).TextFrame.TextRange.Characters(Matches(k).FirstIndex + 2, Matches(k).Length - 1).Font.Subscript = True
        Next
    Next

End Sub

Sub 問題編集()
    Dim i
    i = InputBox("何番の問題を編集しますか? [1-10]")
    If IsNumeric(i) = False Then
        MsgBox ("番号が入力されなかったため,終了します。")
        Exit Sub
    Else
        i = CLng(i)
    End If
    
    Dim str, TRng As TextRange
    Dim Sld1 As Slide: Set Sld1 = ActivePresentation.Slides(1)
    Set TRng = Sld1.Shapes("問題テーブル").Table.Cell(i + 1, 2).Shape.TextFrame.TextRange
    str = InputBox("問題を入力してください。+は半角,→は全角の矢印で。", , TRng.Text)
    If str <> "" Then TRng.Text = str
        
    Dim Reg As New RegExp
    With Reg
        .Global = True
        .Pattern = "[A-Za-z][0-9]+"
        Set Matches = .Execute(str)
    End With

    For i = 0 To Matches.Count - 1
        TRng.Characters(Matches(i).FirstIndex + 2, Matches(i).Length - 1).Font.Subscript = True
    Next
    

End Sub
Sub 表作成()
    Dim Sld2 As Slide: Set Sld2 = ActivePresentation.Slides(2)
    Dim Val(1 To 11, 1 To 6) As String
    Dim タイトル,, 文字色
    タイトル = Array("", "係数", "分子量・式量", "物質量の計算", "物質量(mol)", "個数の計算", "個数(個)", "質量の計算", "質量(g)", "気体の体積計算", "気体の体積(L)")= Array(rgbBlack, rgbLavender, rgbKhaki, rgbLightSteelBlue, rgbWhite, rgbLightSteelBlue, rgbWhite, rgbLightSteelBlue, rgbWhite, rgbLightSteelBlue, rgbWhite)
    文字色 = Array(rgbWhite, rgbBlack, rgbDarkGreen, rgbBlack, rgbRed, rgbBlack, rgbBlack, rgbBlack, rgbBlack, rgbBlack, rgbBlack)
    
    Sld2.Shapes.Range.Delete
    Sld2.Layout = ppLayoutBlank
    
    Dim i, j
    
    For i = 0 To 行数 - 1
        For j = 0 To 列数 - 1
            With Sld2.Shapes.AddLabel(msoTextOrientationHorizontal, j * 列幅, i * 行高さ, 列幅, 行高さ)
                .Name = i + 1 & " " & j + 1
                
                With .TextFrame
                    .AutoSize = ppAutoSizeNone
                    .WordWrap = msoTrue
                    .TextRange.Font.Color.RGB = 文字色(i)
                    If j = 0 Then .TextRange.Text = タイトル(i)
                End With
                
                .Fill.ForeColor.RGB =(i) 'Switch(j = 0, rgbGreen, j <> 0, 色(i))
                If i = 4 Or i = 6 Or i = 8 Or i = 10 Then
                    With .ActionSettings(ppMouseClick)
                        .Action = ppActionRunMacro
                        .Run = "編集"
                    End With
                End If
            End With
        Next
    Next
    
    With Sld2.Shapes.AddLabel(msoTextOrientationHorizontal, 0, 0, 列幅 / 2, 行高さ)
        .TextFrame.AutoSize = ppAutoSizeNone
        .TextFrame.TextRange.Text = "表示"
        .Fill.ForeColor.RGB = rgbRed
        With .ActionSettings(ppMouseClick)
            .Action = ppActionRunMacro
            .Run = "表示"
        End With
    End With
    
    With Sld2.Shapes.AddLabel(msoTextOrientationHorizontal, 列幅 / 2, 0, 列幅 / 2, 行高さ)
        .TextFrame.AutoSize = ppAutoSizeNone
        .TextFrame.TextRange.Text = "変更"
        .Fill.ForeColor.RGB = rgbRed
        With .ActionSettings(ppMouseClick)
            .Action = ppActionFirstSlide
        End With
    End With

    
    With Sld2.Shapes.Range
        .Line.Weight = 1.5
        .Line.ForeColor.RGB = rgbBlack
        With .TextFrame
            .VerticalAnchor = msoAnchorMiddle
            .HorizontalAnchor = msoAnchorCenter
            .MarginLeft = 2
            .MarginRight = 2
            With .TextRange.Font
                .Name = "Meiryo UI"
                .Bold = msoTrue
                .Size = 24
            End With
        End With
    End With
    'Fontサイズ微調整
    For j = 2 To 6
        Sld2.Shapes(6 & " " & j).TextFrame.TextRange.Font.Size = 18
    Next
    Sld2.Shapes("10 1").TextFrame.TextRange.Font.Size = 20
    Sld2.Shapes("11 1").TextFrame.TextRange.Font.Size = 20
    'ここまで
    SlideShowWindows(Index:=1).View.GotoSlide Index:=2
    
End Sub

Sub 編集(TShp As Shape)
    Dim Sld2 As Slide: Set Sld2 = ActivePresentation.Slides(2)
    'Dim TShp As Shape: Set TShp = Sld2.Shapes("7 2") 'デバッグ用
    Dim TargetI, TargetJ, ret
    TargetI = Split(TShp.Name)(0)
    TargetJ = Split(TShp.Name)(1)
    ret = InputBox("値を入力 個数は 数値E指数 の形で")
    If IsNumeric(ret) = False Then Exit Sub
    
    Dim Val(1 To 11, 1 To 6) As Variant, i As Long, j As Long, tmp As Variant
    Val(TargetI, TargetJ) = CSng(ret)
    For i = 2 To 3
        For j = 2 To 6
            tmp = Sld2.Shapes(i & " " & j).TextFrame.TextRange.Text
            If tmp <> "" Then Val(i, j) = CSng(tmp)
        Next
    Next
    
    Sld2.Shapes("1 1").TextFrame.TextRange.Text = TargetI & " " & TargetJ
    
    Select Case TargetI
        Case Is = 5
            Val(1, TargetJ) = CSng(ret)
        Case Is = 7
            Val(1, TargetJ) = CSng(ret) / NA
        Case Is = 9
            Val(1, TargetJ) = CSng(ret) / CSng(Val(3, TargetJ))
        Case Is = 11
            Val(1, TargetJ) = CSng(ret) / 22.4
    End Select
    
    For j = 2 To 6
        If Val(2, j) <> "" Then
            Val(1, j) = Val(1, TargetJ) / Val(2, TargetJ) * Val(2, j)
            Val(5, j) = 有効数字表示(Val(1, j), 2, False)
            Val(4, j) = 有効数字表示(Val(5, TargetJ), 2, False) & "÷" & Val(2, TargetJ) & "×" & Val(2, j)
        End If
    Next
    
    For j = 2 To 6
        If Val(2, j) <> "" Then
            Val(6, j) = "6.0×1023×" & Val(5, j)
            Val(7, j) = 有効数字表示(NA * CSng(Val(1, j)), 2, True)
            Val(8, j) = Val(3, j) & "×" & Val(5, j)
            Val(9, j) = 有効数字表示(Val(3, j) * CSng(Val(1, j)), 2, False)
            Val(10, j) = "22.4×" & Val(5, j)
            Val(11, j) = 有効数字表示(22.4 * CSng(Val(1, j)), 3, False)
        End If
    Next
    
    Call 消去
    DimAs Variant, 開始 As Long, 長さ As Long= Array(rgbBlack, rgbLavender, rgbKhaki, rgbLightSteelBlue, rgbWhite, rgbLightSteelBlue, rgbWhite, rgbLightSteelBlue, rgbWhite, rgbLightSteelBlue, rgbWhite)
    For i = 4 To 11
        For j = 2 To 6
            If Val(i, j) <> "" Then
                With Sld2.Shapes(i & " " & j).TextFrame
                    .TextRange = Val(i, j)
                    .TextRange.Font.Color.RGB =(i - 1)
                    If i = 7 Then
                        tmp = Val(7, j)
                        開始 = InStr(tmp, "^")
                        長さ = Len(tmp) - 開始
                        .TextRange.Font.Superscript = msoFalse
                        .TextRange.Text = Replace(tmp, "^", "")
                        .TextRange.Characters(開始, 長さ).Font.Superscript = msoTrue
                    End If
                End With
            End If
        Next
    Next
    
    Sld2.Shapes(TargetI & " " & TargetJ).TextFrame.TextRange.Font.Color.RGB = rgbRed
End Sub
Sub 表示()
    Dim TargetI As Long, TargetJ As Long, i As Long, j As Long, k As Long, tmp As String
    Dim Val(1 To 11, 2 To 6) As Variant

    Dim Sld2 As Slide: Set Sld2 = ActivePresentation.Slides(2)
    tmp = Sld2.Shapes("1 1").TextFrame.TextRange.Text
    TargetI = Split(tmp)(0)
    TargetJ = Split(tmp)(1)
    
    For i = 2 To 11
        For j = 2 To 6
            Val(i, j) = Sld2.Shapes(i & " " & j).TextFrame.TextRange.Text
            If i = 7 Then
                For k = 1 To Len(Val(7, j))
                    If Sld2.Shapes("7 " & j).TextFrame.TextRange.Characters(k).Font.Superscript = msoTrue Then
                        Val(7, j) = Left(Val(7, j), k - 1) & "^" & Mid(Val(7, j), k)
                        Exit For
                    End If
                Next
            End If
        Next
    Next
    
    Dim 物質量元文字数 As Long, 物質量文字数 As Long, 係数元文字数 As Long, 係数文字数 As Long, 開始 As Long, 長さ As Long
    物質量元文字数 = Len(Val(5, TargetJ))
    係数元文字数 = Len(Val(2, TargetJ))
    For i = 1 To 11
        For j = 2 To 6
            With Sld2.Shapes(i & " " & j)
                If Val(2, j) <> "" Then
                    If i = TargetI And j = TargetJ Then
                        .Fill.ForeColor.RGB = rgbYellow
                        .TextFrame2.TextRange.Font.Highlight = rgbYellow
                    End If
                    物質量文字数 = Len(Val(5, j))
                    係数文字数 = Len(Val(2, j))
                    tmp = Val(i, j)
                    Select Case i
                        Case Is = 2
                            .TextFrame.TextRange.Font.Color.RGB = rgbBlack
                            If j = TargetJ Then .TextFrame2.TextRange.Font.Highlight = rgbLime
                        Case Is = 3
                            .TextFrame.TextRange.Font.Color.RGB = rgbDarkGreen
                        Case Is = 4
                            With .TextFrame.TextRange
                                .Font.Color.RGB = rgbBlack
                                .Characters(1, 物質量元文字数).Font.Color.RGB = rgbBlue
                            End With
                            .TextFrame2.TextRange.Characters(1, InStr(tmp, "÷") - 1).Font.Highlight = rgbYellow
                            .TextFrame2.TextRange.Characters(物質量元文字数 + 2, 係数元文字数).Font.Highlight = rgbLime
                        Case Is = 5
                            If j = TargetJ Then
                                .TextFrame.TextRange.Font.Color.RGB = rgbBlack
                                .Fill.ForeColor.RGB = rgbYellow
                                .TextFrame2.TextRange.Font.Highlight = rgbYellow
                            End If
                            With .TextFrame.TextRange
                                .Font.Color.RGB = rgbRed
                                If j = TargetJ Then .Font.Color.RGB = rgbBlue
                            End With
                        Case Is = 6
                            With .TextFrame.TextRange
                                .Font.Color.RGB = rgbBlack
                                .Characters(7, 2).Font.Superscript = msoTrue
                                .Characters(10, 物質量文字数).Font.Color.RGB = Switch(j <> TargetJ, rgbRed, j = TargetJ, rgbBlue)
                            End With
                        Case Is = 7
                            With .TextFrame.TextRange
                                .Font.Color.RGB = rgbBlack
                                tmp = Val(7, j)
                                開始 = InStr(tmp, "^")
                                長さ = Len(tmp) - 開始
                                .Font.Superscript = msoFalse
                                .Text = Replace(tmp, "^", "")
                                .Characters(開始, 長さ).Font.Superscript = msoTrue
                            End With
                        Case Is = 8, 10
                            With .TextFrame.TextRange
                                .Font.Color.RGB = rgbBlack
                                If i = 8 Then .Characters(1, Len(Val(3, j))).Font.Color.RGB = rgbGreen
                                開始 = InStr(tmp, "×")
                                長さ = Len(tmp) - 開始
                                .Characters(開始 + 1, 長さ).Font.Color.RGB = Switch(j <> TargetJ, rgbRed, j = TargetJ, rgbBlue)
                            End With
                        Case Is = 9, 11
                            .TextFrame.TextRange.Font.Color.RGB = rgbBlack
                    End Select
                End If
            End With
        Next j
    Next i
    Sld2.Shapes(TargetI & " " & TargetJ).TextFrame.TextRange.Font.Color.RGB = rgbRed

    
End Sub
Sub 矢印作成(Val As String)
    Dim Sld2 As Slide: Set Sld2 = ActivePresentation.Slides(2)

    Dim i
    For i = 1 To Len(Val)
        If Mid(Val, i, 1) = "+" Then
            With Sld2.Shapes.AddShape(msoShapeCross, 列幅 * (i + 1) - 12.5, 15, 25, 25)
                .Adjustments(1) = 0.4
                .Fill.ForeColor.RGB = rgbWhite
            End With
        Else
            With Sld2.Shapes.AddShape(msoShapeRightArrow, 列幅 * (i + 1) - 12.5, 17.5, 25, 20)
                .Adjustments(1) = 0.3
                .Adjustments(2) = 0.4
                .Fill.ForeColor.RGB = rgbWhite
            End With
        End If
    Next
End Sub

Sub 消去()
    Dim Sld2 As Slide: Set Sld2 = ActivePresentation.Slides(2)
    Dim タイトル,, 文字色
    タイトル = Array("", "係数", "分子量・式量", "物質量の計算", "物質量(mol)", "個数の計算", "個数(個)", "質量の計算", "質量(g)", "気体の体積計算", "気体の体積(L)")= Array(rgbBlack, rgbLavender, rgbKhaki, rgbLightSteelBlue, rgbWhite, rgbLightSteelBlue, rgbWhite, rgbLightSteelBlue, rgbWhite, rgbLightSteelBlue, rgbWhite)
    文字色 = Array(rgbWhite, rgbBlack, rgbDarkGreen, rgbBlack, rgbRed, rgbBlack, rgbBlack, rgbBlack, rgbBlack, rgbBlack, rgbBlack)
    
    Dim i, j
    For i = 2 To 11
        For j = 2 To 6
            With Sld2.Shapes(i & " " & j)
                .Fill.ForeColor.RGB =(i - 1)
                .TextFrame2.TextRange.Font.Highlight = .Fill.ForeColor.RGB
                With .TextFrame.TextRange
                    If i > 3 Then .Text = ""
                    With .Font
                        .Color.RGB = 文字色(i - 1)
                        .Superscript = msoFalse
                    End With
                End With
            End With
        Next
    Next
End Sub

Function 式量(化学式 As String) As Single

    Dim arr原子量 As Variant
    arr原子量 = Split(原子量, ",")
    
    Dim Reg As New RegExp, Matches As MatchCollection
    With Reg
        .Global = True
        .Pattern = "([A-Z][a-z]?)([0-9]*)"
        Set Matches = .Execute(化学式)
    End With
    
    Dim i, j, 原子量_ As Single, 原子 As String, tmp As String, 添え字 As Long
    For i = 0 To Matches.Count - 1
        
        原子 = Matches(i).SubMatches(0)
        For j = 0 To UBound(arr原子量) - 2 Step 2
            If 原子 = arr原子量(j) Then 原子量_ = CSng(arr原子量(j + 1))
        Next
        
        tmp = Matches(i).SubMatches(1)
        If tmp = "" Then 添え字 = 1 Else 添え字 = CLng(tmp)
        式量 = 式量 + 原子量_ * 添え字
    Next

End Function

Function 個数(ByVal 物質量 As Single) As Single
    個数 = 物質量 * NA
End Function
Function 質量(ByVal 物質量 As Single, モル質量 As Long) As Single
    質量 = 物質量 * モル質量
End Function
Function 体積(ByVal 物質量 As Single) As Single
    体積 = 物質量 * 22.4
End Function

Function 物質量_個数(ByVal 個数 As Single) As Single
    物質量_個数 = 個数 / NA
End Function

Function 物質量_質量(ByVal 質量 As Single, モル質量 As Long) As Single
    物質量_質量 = 質量 / モル質量
End Function

Function 物質量_体積(ByVal 体積 As Single) As Single
    物質量_個数 = 体積 / 22.4
End Function

Function 有効数字表示(As Variant,As Long, 指数表示 As Boolean) As String
    Dim Val_ As String, Format_ As String
    If= 1 Then Format_ = "0" Else Format_ = "0." & String(- 1, "0") & "e-0"
    Val_ = Format(CSng(), Format_)
    
    If 指数表示 = True Then
        有効数字表示 = Replace(Val_, "e", "×10^")
    Else
        有効数字表示 = CSng(Left(Val_, InStr(Val_, "e") - 1) & "e" & Mid(Val_, InStr(Val_, "e") + 1))
        
        If InStr(有効数字表示, "E") = 0 Then
            Dim 数値スタート As Long, i As Long, 数値桁 As Long
            For i = 1 To Len(有効数字表示)
                If Mid(有効数字表示, i, 1) <> "0" And Mid(有効数字表示, i, 1) <> "." Then
                    数値スタート = i
                    Exit For
                End If
                
            Next
            
            数値桁 = Len(有効数字表示) - 数値スタート + 1
            If> 数値桁 Then
                If Len(有効数字表示) = 1 Then 有効数字表示 = 有効数字表示 & "."
                有効数字表示 = 有効数字表示 & String(- 数値桁, "0")
            End If
        End If
    End If
End Function