VBAで、For/If構文内の入れ子構造の一部が頻出する場合、それを1回書くだけにできないか？

Question

前提・実現したいこと

パワーポイント(for Mac 2016)において、全スライド・オブジェクトに対して、テキスト検索・変換するコードを作成しています。
反復して同一の構文を書かなければいけない部分を、なんとか1回の記載で済むようにできないかと模索しています。
少しわかりにくいですが、マクロのVBAで、For構文、If構文内の入れ子構造の下層(中身)部分が、
並列するFor/If構文の下層と共通しており、
かつ今後の経過で下層部分のみ書き換える可能性が高い場合、
同一構文は1回書くだけにした方が効率的です。

具体的には、以下の通りです。

該当のソースコード

Option Explicit
Sub 下付き文字にするコード例()
Dim pos As Long
Dim Strnum As Long
Dim RepList() As Variant
Dim sld
Dim shp
Dim txt As String
   RepList = Array(“●”, “●”, “●")  

For Each sld In ActivePresentation.Slides
 For Each shp In sld.Shapes
  If shp.TextFrame.HasText Then ‘通常のテキストボックスの場合　①
   txt = shp.TextFrame2.TextRange.Text '元テキスト内容を一旦格納 
    For i = 0 To 2 ‘★
    Strnum = 1
     While InStr(Strnum, txt, RepList(i), vbBinaryCompare) > 0
      pos = InStr(Strnum, txt, RepList(i), vbBinaryCompare)
      shp.TextFrame2.TextRange.Characters(pos + 1).Font.Subscript = msoTrue
      Strnum = Strnum + 2
    Wend
   Next i ‘★★
  End If

   If shp.HasTable Then ‘テーブル内の場合　②
        For Each clm In shp.Table.Columns
             For Each cl In clm.Cells
                 txt = cl.Shape.TextFrame2.TextRange.Text
                     上記★〜★★が共通
                Next cl
            Next clm
     End If

 Next shp
Next sld
End Sub

①変換対象がテキストボックス内の場合と、②表テーブル内のセルで場合とで、中身の動作は★〜★★で共通しています。
その★〜★★部分のみ今後変更する可能性がある場合、書き換える部分が多いほど煩雑になるし、構文エラーのリスクも高まります。

試したこと

浅学ですが、Call構文→Private Sub()で
★〜★★部分を抽出してみましたが、
「オブジェクトの指定が必要」などと表示され、Subプロシージャを単純に分けるとうまくいかないようでした。

エラーの種類
・Call→ Private Sub() ()は空欄
→「変数が定義されていません」
・Call→ Private Sub(ByVal Strnum As Long, txt As String, RepList() As Variant, pos As Long)
→構文全体が青くなり、エラー表示はされないがエラー音が鳴って何も起こらない
・Call→ Function(ByVal Strnum As Long, txt As String, RepList() As Variant, pos As Long)
→エラー表示はされないが、エラー音が鳴って何も起こらない
・txt = she. 〜〜　をPrivate Subに入れないようにすると、「オブジェクトの指定が必要」のエラーは無くなりました。

補足情報（FW/ツールのバージョンなど）

Mac OS Mojave
Microsoft Office Powerpoint for Mac ver 15.33

Comments

[meg_]

共通部分を関数化する方向で良いと思います。

[hSpringsteen]

早速の回答をありがとうございます。
shp.TextFrame2.TextRange.Characters(pos + 1).Font.Subscript = msoTrue部分でテキストを書き換え終了しており、戻り値がないセッティングだと思われますが、
Functionプロシージャで良いのでしょうか？

定義済みの変数は、
Function 共通する部分(pos As Long, Strnum As Long, RepList() As Variant)
で記載し、Function内に共通部分を記載、Call構文で呼び出す、という流れでしょうか？

[hatena19]

> 浅学ですが、Call構文→Private Sub()で
> ★〜★★部分を抽出してみましたが、
そのコードを質問に追加して、どこで「オブジェクトの指定が必要」のエラーがでるか提示してください。

あと、モジュール先頭に Option Explicit を追加して変数宣言を強制して、使用する変数はすべて宣言するようにしましょう。

[meg_]

Sub()で良いかと思います。エラーは必要な引数が不足していたのではないでしょうか？

[hatena19]

Option Explicit 宣言と変数を必ず宣言して使用するという癖をつけましょう。
引数で渡す変数は、少なくとも shp と txt は必須です。RepList, Strnum, pos, i はSub内で宣言すればいいでしょう。

このヒントでうまくできないなら、現状のコードをすべて提示してどこでエラーが出るかも提示してください。

[hSpringsteen]

CallするプロシージャはFunctionでもPrivate Subでもなく、「Sub 作業部分()」で良いということでしょうか。
引数引き渡しについては、今回のように引用プロシージャ内で作業が完結する(値を返されない)場合、
Callがある部分の上層の変数(sld,shp,txt)を引数とし、作業部分(下層)の変数(i, pos, Strnum, RepList() )は無視する形になりますか？

具体的には
Call 作業部分(sld, shp, txt)
Sub 作業部分(ByVal sld, ByVal shp, ByVal txt As String)
という引数記載になりますか？

上記だと無反応で、ByVal〜部分を消してみると、RepList()の定義が必要、とコメントが出てしまいます

Answer 1

すでにベストアンサーは出ていますが参考・応用編として。

meg_ さんや hatena19 さんの話のとおり、共通部分を別処理にしていることが前提で、
そのうえで、「共通部分」として、今の処理とは全く別の処理もしたくなった場合の話です。

元の処理を残したままで作ろうとすると、再度For/If構文の記述が必要になりちょっと面倒だったり、パターン分けを追加したい場合に修正漏れが出てしまいます。

このような場合には、「処理対象を見つける」と「処理をする」を別にする、という手があります(他の言語では他にも手がありますがMacのVBAだと難しい)。

下記のコードを例にすると、
「処理対象を見つける」がGetTextRange2FromSlide関数になります。
SlideからTextRange2(図形のテキスト)をCollectionとして取得します。
そして、「処理をする」が作業部分2になります。

このようにすることで、「スライド内の図形からテキスト部分を取得する」という処理が抽出でき、他の処理をしたい場合にも使いまわしやすくなったり、対象を追加したい場合(e.g. グループ化された図形)にも、GetTextRange2FromSlideだけを修正すればいい、ということになります。

なお、以下のコードはWindowsで動作確認はしていますが、Macでは一部型宣言がうまく認識されないかもしれません(参照設定依存のため)。

Sub 下付き文字にするコード例2()
    Dim pres As PowerPoint.Presentation '`PowerPoint.`は無くても動くはず(以下同様)
    Set pres = Application.ActivePresentation
    
    '各スライド毎にループ。
    Dim sld As PowerPoint.Slide
    For Each sld In pres.Slides
        
        'スライド内の`TextRange2`オブジェクトを取得。
            '`VBA.`は無くても動くはず(以下同様)
        Dim txtRngs As VBA.Collection '(Of Office.TextRange2)
        Set txtRngs = GetTextRange2FromSlide(sld)
        
        Dim tr As Office.TextRange2 '`Office.`は無くても動くはず(以下同様)
        For Each tr In txtRngs
            '下付き文字にする
            Call 作業部分2(tr)
        Next tr
        
    Next sld
    
End Sub

'スライド内から、テキストを持っている図形のTextRange2を取得する。
Public Function GetTextRange2FromSlide(inSld As PowerPoint.Slide) As VBA.Collection '(Of Office.TextRange2)
    Dim col As VBA.Collection 'Macでも使えるはずだけど、何か問題があったら`VBA.`を消してみる
    Set col = New VBA.Collection
    
    Dim shp As PowerPoint.Shape
    For Each shp In inSld.Shapes
        
        If shp.TextFrame2.HasText Then '通常のテキストボックスの場合　①
            
            col.Add shp.TextFrame2.TextRange
            
        ElseIf shp.HasTable Then  'テーブル内の場合　②
            
            Dim clm As PowerPoint.Column
            For Each clm In shp.Table.Columns
                
                Dim cl As PowerPoint.Cell
                For Each cl In clm.Cells
                    
                    col.Add cl.Shape.TextFrame2.TextRange
                    
                Next cl
                
            Next clm
            
        End If
        
    Next shp
    
    Set GetTextRange2FromSlide = col
End Function

Private Sub 作業部分2(inTxtRng As Office.TextRange2)
    'RepListの後ろの文字を下付き文字にする。
    Dim RepList() As Variant
    RepList = Array("●", "●", "●")
    
    Dim txt As String
    txt = inTxtRng.Text
    
    Dim i As Long
    For i = LBound(RepList) To UBound(RepList) '0 To 2 ではなく、配列の下限・上限から指定した方が修正時の手間が減る。
        Dim Strnum As Long
        Dim pos As Long
        Strnum = 1
        
        Do
          pos = InStr(Strnum, txt, RepList(i), vbBinaryCompare)
          If pos <= 0 Then Exit Do
          
          inTxtRng.Characters(pos + 1).Font.Subscript = msoTrue
          Strnum = Strnum + 2
        Loop
   Next i
End Sub

Comments

[hSpringsteen]

アドバンスの解説をありがとうございます。取り急ぎコメントしますが、勉強して理解しながら、取り入れていこうと思います。

Answer 2

まずは、Option Explicit についてWEB検索して意味を理解してください。
そしてOption Explicitをモジュールの先頭に記述して、変数は必ず宣言するようにしましょう。
それをしないとなかなかスキルアップはできないと思います。

コードとしては下記のような感じになると思います。
PowerPointのVBAを書いたことがないので、提示されているコードを単純に分割しただけ、あと変数を宣言するようにしただけです。動作確認はしてませんので、参考にして適宜修正してください。

Option Explicit

Sub 下付き文字にするコード例()
    Dim sld As Object
    Dim shp As Object
    Dim clm As Object
    Dim cl As Object
    Dim txt As String
    
    For Each sld In ActivePresentation.Slides
        For Each shp In sld.Shapes
            If shp.TextFrame.HasText Then '通常のテキストボックスの場合　①
                txt = shp.TextFrame2.TextRange.Text '元テキスト内容を一旦格納
                Call 作業部分(txt, shp)
            End If

            If shp.HasTable Then 'テーブル内の場合　②
                For Each clm In shp.Table.Columns
                    For Each cl In clm.Cells
                        txt = cl.Shape.TextFrame2.TextRange.Text
                        Call 作業部分(txt, cl.Shape)
                    Next cl
                Next clm
            End If

        Next shp
    Next sld
End Sub


Private Sub 作業部分(txt As String, shp As Object)
    Dim RepList As Variant
    RepList = Array("●", "●", "●")
    
    Dim pos As Long
    Dim Strnum As Long
    Dim i As Long
    For i = 0 To 2 '★
        Strnum = 1
        While InStr(Strnum, txt, RepList(i), vbBinaryCompare) > 0
            pos = InStr(Strnum, txt, RepList(i), vbBinaryCompare)
            shp.TextFrame2.TextRange.Characters(pos + 1).Font.Subscript = msoTrue
            Strnum = Strnum + 2
        Wend
    Next i '★★
End Sub

Comments

[hSpringsteen]

ありがとうございます。上記回答の引数にsldも加えたところ、無事に成功いたしました。
初めてまともに呼び出しプロシージャを使用しましたが、引数の使い方について要諦を理解できた気がします。
この経験を軸に勉強していきたいです。
　作業時間自体は伸びて重くなった気がするのが気になりますが、これから検証していこうと思います。
変数宣言についてのご指摘も勉強になります。ありがとうございました。

[mike2mike4]

解決したのでしたら、「解決済み」にしてくださいな。お願いします。

[hSpringsteen]

送信エラーが起きていました。ベストアンサーをつけました。すみません