同じ順番で現れる　不特定桁の数値の比較をしてみる。 - インストールレスプログラミング( ´ー`)

反応式の奴は落ち着いたんですが，一度できたあとも改善できないか遊んでいたら，記事になりそうでしたので書いてみています。

まずは準備のコード。

Sub 準備()
    Dim TSld As Slide: Set TSld = ActivePresentation.Slides(1)
    With TSld.Shapes.AddLabel(msoTextOrientationHorizontal, 0, 50, 300, 50)
        With .TextFrame
            .AutoSize = ppAutoSizeNone
            With .TextRange
                .Text = "H 4,S 100,Cl 1,Mn 3"
                .Font.Color.RGB = rgbBlack
            End With
        End With
        .Line.ForeColor.RGB = rgbBlack
        .Line.Weight = 2
        .Name = "Label1"
    End With
    
    With TSld.Shapes.AddLabel(msoTextOrientationHorizontal, 0, 200, 300, 50)
        With .TextFrame
            .AutoSize = ppAutoSizeNone
            With .TextRange
                .Text = "H 8,S 9,Cl 5,Mn 3"
                .Font.Color.RGB = rgbBlack
            End With
        End With
        .Line.ForeColor.RGB = rgbBlack
        .Line.Weight = 2
        .Name = "Label2"
    End With
End Sub

これを実行すると，
f:id:chemiphys:20181019191143p:plain
二つのテキストボックスを挿入し，中に元素記号と数字が並んでいる状態になると思います。
S 100　とかあほな数字を書いていますが，まぁ桁をずらしたかっただけです。

さて，この数字部分だけが等しいかどうかを判別し，異なる場合は色をつける。

こういうことをしようとすると，普通にやるとまぁまぁ面倒になるんじゃないかと思います。

簡単な正規表現を使ってそれを処理したのが次のコード

Sub 照合()
    Dim TSld As Slide: Set TSld = ActivePresentation.Slides(1)
    Dim Lbl1 As TextRange: Set Lbl1 = TSld.Shapes("Label1").TextFrame.TextRange
    Dim Lbl2 As TextRange: Set Lbl2 = TSld.Shapes("Label2").TextFrame.TextRange
    
    'Microsoft VBScript Regular Expression 5.5への参照設定が必要です
    Dim Reg As New RegExp, Mat1 As MatchCollection, Mat2 As MatchCollection
    
    With Reg
        .Global = True
        .Pattern = "[0-9]+"
        Set Mat1 = .Execute(Lbl1.Text)
        Set Mat2 = .Execute(Lbl2.Text)
    End With
    
    Lbl1.Font.Color.RGB = rgbBlack
    Lbl2.Font.Color.RGB = rgbBlack
    Dim i, Arr As Variant
    Arr = Array(rgbRed, rgbBlue, rgbYellow, rgbPink, rgbGreen)
    
    For i = 0 To Mat1.Count - 1
        If Mat1(i) <> Mat2(i) Then
            Lbl1.Characters(Mat1(i).FirstIndex + 1, Mat1(i).Length).Font.Color.RGB = Arr(i)
            Lbl2.Characters(Mat2(i).FirstIndex + 1, Mat2(i).Length).Font.Color.RGB = Arr(i)
        End If
    Next

End Sub