タイトル通りです。
文字の均等割り付けは最初の文字だけ有効です。
2個以上あった場合、2個目以降は均等されていません。
フォルダにあるワードファイルを全部開きます。

Sub テキストボックス内置換し均等割付()

    Dim PATH As String
    PATH = "C:\hogehoge\kakunin"
    
    Dim buf As String
    buf = PATH & "\*.doc*"
    buf = Dir(buf)
    
    Do While buf <> ""
    
    If buf <> ThisDocument.Name Then
    Documents.Open PATH & "\" & buf
    
    Dim i As Integer
    'Shapeオブジェクトに対して置換実行
    For i = 1 To ActiveDocument.Shapes.Count
 
        ActiveDocument.Shapes(i).Select
        Selection.Find.ClearFormatting
        Selection.Find.Replacement.ClearFormatting
        
        With Selection.Find
           .Text = "しれとこ部くまこう課" '検索する文字列
           .Execute Replace:=wdReplaceAll, replacewith:="しれとこ部べあだぜ課" '置換する文字列
           
           .Text = "令和3年" '検索する文字列
           .Execute Replace:=wdReplaceAll, replacewith:="令和4年" '置換する文字列
           
           On Error Resume Next
           Dim str As String
           str = ActiveDocument.Shapes(i).TextFrame.TextRange.Text
           
           If str Like "*しれとこ部べあだぜ課*" Then
    '            ActiveDocument.Shapes(i).Select
                Selection.Start = InStr(str, "しれとこ部べあだぜ課") - 1
                Selection.End = InStr(str, "しれとこ部べあだぜ課") + Len("しれとこ部べあだぜ課") - 1
                
                '文字均等割り付け
                Selection.Range.FitTextWidth = CentimetersToPoints(10)
            End If
            Stop ’保存する前に一回止めまーす     
            Documents.Save
        End With
    Next i
    
    Stop ’一回止めまーす
    Documents.Close
    End If
    
    buf = Dir()
    Loop
    
End Sub

以下、参考にさせていただいたサイトさまです。

【コード】カーソル位置を取得するWordマクロ
テキストボックス内の文字を置換するマクロ

おすすめの記事