Wordの見出しに番号を付けたいときに、リストと対応させるのが面倒なため作成しました。（画面の操作数が多すぎるため。テンプレ－トを使えばよいという話もありますが、テンプレート自体を都度作ったりすることがあるので）
実行後はこのように出力されます。
- 開いているファイルのリストの設定、見出しの設定を変更しますので、注意してください。
- 見出しの番号は、そのファイルに設定されてるままでVBAで変更はしていません（特に変更してなければ、1、1.1、1.1.1、…）
- リストと見出しの対応以外に、1)インデントの調整、2)番号に続く空白の扱いの変更、3)見出し太字の解除をしています。
- インデントは見出し番号が1桁の場合の位置に合わせています。環境によりずれる可能性もあると思います。
- 初回実行後、左インデントからの距離、インデント位置が画面上に反映されないことがあります。２回同じ処理を流しても大丈夫なので、２回流してください。（設定自体は入ってるので、画面表示がなぜかされない事象のようです…）
Option Explicit
Sub リストと見出しの設定()
Dim MsgRtn As String 'メッセージボックスの返り値
Dim StyleSettingMode As Long '動作モード（1以外:リストと見出しの対応のみ、1:追加設定あり）
Dim i As Long
'動作モード
StyleSettingMode = 1
'--------------------------------------
'開始メッセージ
'--------------------------------------
MsgRtn = MsgBox("処理を開始しますか？" & vbCrLf & vbCrLf & _
"[注意]" & vbCrLf & _
"アクティブになっているファイルのカーソル位置に見出しが設定されますので、新規ファイルを開いてから実行することを推奨します。", _
vbOKCancel + vbInformation, Title:="開始")
If MsgRtn = vbCancel Then Exit Sub
For i = 1 To 9
'------------------------------
'見出し用の文字列を入力
'------------------------------
Selection.TypeText Text:="見出し" & i & "見出し" & i & "見出し" & i & "見出し" & i & "見出し" & i _
& "見出し" & i & "見出し" & i & "見出し" & i & "見出し" & i & "見出し" & i _
& "見出し" & i
'------------------------------
'リストと見出しの対応関係設定
'------------------------------
With ListGalleries(wdOutlineNumberGallery).ListTemplates(1).ListLevels(i)
'リストと見出しの対応関係設定
.LinkedStyle = "見出し " & i
End With
'反映
Selection.Range.ListFormat.ApplyListTemplateWithLevel ListTemplate:= _
ListGalleries(wdOutlineNumberGallery).ListTemplates(1), _
ContinuePreviousList:=False, ApplyTo:=wdListApplyToWholeList, _
DefaultListBehavior:=wdWord10ListBehavior
'------------------------------
'選択位置のスタイルを見出しに設定
'------------------------------
Selection.Style = ActiveDocument.Styles("見出し " & i)
'------------------------------
'リストの設置変更
'------------------------------
If StyleSettingMode = 1 Then
With ListGalleries(wdOutlineNumberGallery).ListTemplates(1).ListLevels(i)
.Alignment = wdListLevelAlignLeft
'左インデントからの距離/インデント位置
.NumberPosition = MillimetersToPoints(0)
Select Case i
Case 1
.TextPosition = MillimetersToPoints(3.8)
Case 2
.TextPosition = MillimetersToPoints(7)
Case 3
.TextPosition = MillimetersToPoints(10.6)
Case 4
.TextPosition = MillimetersToPoints(14.1)
Case 5
.TextPosition = MillimetersToPoints(17.7)
Case 6
.TextPosition = MillimetersToPoints(21.3)
Case 7
.TextPosition = MillimetersToPoints(24.9)
Case 8
.TextPosition = MillimetersToPoints(28.5)
Case 9
.TextPosition = MillimetersToPoints(32.1)
End Select
'番号に続く空白の扱い（デフォルトはタブ:wdTrailingTab, 空白:wdTrailingSpace）
.TrailingCharacter = wdTrailingSpace
End With
'反映
Selection.Range.ListFormat.ApplyListTemplateWithLevel ListTemplate:= _
ListGalleries(wdOutlineNumberGallery).ListTemplates(1), _
ContinuePreviousList:=False, ApplyTo:=wdListApplyToWholeList, _
DefaultListBehavior:=wdWord10ListBehavior
End If
'------------------------------
'改行
'------------------------------
Selection.TypeParagraph
Next i
If StyleSettingMode = 1 Then
'見出し4と見出し6はデフォルトが太字のため、解除
ActiveDocument.Styles(wdStyleHeading4).Font.Bold = False
ActiveDocument.Styles(wdStyleHeading6).Font.Bold = False
End If
End Sub
動作モード
動作モードを1にしていますが、0で動作させた場合は対応関係だけを設定するので、次の通りになります。（階層が下がるにつれ、インデントがかなり広いです。また見出し4と見出し6はデフォルトで太字になっているのも必要なさそうなので解除しています。番号に続く文字はデフォルトタブですが、タブがいいかスペースがいいかはメリデメがあるので、好みかと思います）
