一問一答の一歩

表形式になっているWordのヘッダーを値を編集するマクロを紹介している例が少なかったので、リロケーダブルなコ－ドの例として紹介します。

構成については以下の通りです。

1. プログラムの概要
2. 使用する関数
3. ソースコード
4. 補足､リロケーダブルなコードにするには

以下のようなWordファイルのヘッダーの中の表の値を書き換えます。

書換えの対象となるファイルは一つだけでなく、以下のような指定したフォルダの中にあるファイル全てのワ－ドファイルが対象となっています。

Wordの画面は以下のようなものを想定しており､表の指定した部分に読み込み対象のファイルの位置や、修正対象となる値を書き込み､「修正開始」のボタンを押すことでプログラムが実行されます。

VBAでwordを取り扱う関数については例が多く、分かりやすいサイトがあったので共有しておきます。

〇WordのVBAの基本操作

Excel VBAを使用したWord文書のヘッダー・フッター情報の一括更新方法 | IT trip

複数のWord文書を手作業で更新するのは時間と労力がかかります。特に、会社のロゴや住所など、統一されたヘッダー・フッターの情報を複数の文書に反映させる必要がある場合、効率的な方法が求められます。この記事では、Excel VBAを利用して、W

https://ittrip.xyz/vba/excel-vba-update-word-headers-footers

Sub correct_wordheader_table()
'----------------------------------------------
'概要: フォルダ内全てのワードファイルの表形式で作成されたヘッターを修正する
'機能名:  correct_header_table
'引数: なし
'戻り値: なし
'備考:フォルダ内全てのワードファイルの表形式で作成されたヘッターを修正す
'----------------------------------------------
Dim objWord As Object
Set objWord = CreateObject("Word.Application")
objWord.Visible = True

Dim objFso As Object
Set objFso = CreateObject("Scripting.FileSystemObject")
'パスのスペースと改行文字を削除
Dim path As String
Dim replace_flag As Integer
Dim tmpstr As String
tmpstr = ActiveDocument.Tables(1).Cell(1, 2).Range.Text
tmpstr = Replace(Replace(tmpstr, vbCr, ""), " ", "")
tmpstr = Left(tmpstr, Len(tmpstr) - 1)
path = tmpstr & "\"

Dim headerText As String
Dim verText As String
Dim row1 As Integer
Dim col1 As Integer
Dim beforestr1 As String
Dim afterstr1 As String

'修正の有無の数字を1(修正する)に変更する。
replace_flag = 1

'修正対象行をint型に変換
tmpstr = Replace(Replace(ActiveDocument.Tables(1).Cell(2, 2).Range.Text, vbCr, ""), " ", "")
tmpstr = Left(tmpstr, Len(tmpstr) - 1)
'MsgBox tmpstr
row1 = CInt(tmpstr)

'修正対象列をint型に変換
tmpstr = Replace(Replace(ActiveDocument.Tables(1).Cell(3, 2).Range.Text, vbCr, ""), " ", "")
tmpstr = Left(tmpstr, Len(tmpstr) - 1)
'MsgBox tmpstr
col1 = CInt(tmpstr)

tmpstr = ActiveDocument.Tables(1).Cell(4, 2).Range.Text
tmpstr = Replace(Replace(tmpstr, vbCr, ""), " ", "")
beforestr1 = Left(tmpstr, Len(tmpstr) - 1)
'MsgBox "対象文字列：beforestr1"

tmpstr = ActiveDocument.Tables(1).Cell(5, 2).Range.Text
tmpstr = Replace(Replace(tmpstr, vbCr, ""), " ", "")
afterstr1 = Left(tmpstr, Len(tmpstr) - 1)

Dim row2 As Integer
Dim col2 As Integer
Dim beforestr2 As String
Dim afterstr2 As String

'修正対象行をint型に変換
tmpstr = Replace(Replace(ActiveDocument.Tables(1).Cell(2, 4).Range.Text, vbCr, ""), " ", "")
tmpstr = Left(tmpstr, Len(tmpstr) - 1)
'MsgBox tmpstr
row2 = CInt(tmpstr)

'修正対象列をint型に変換
tmpstr = Replace(Replace(ActiveDocument.Tables(1).Cell(3, 4).Range.Text, vbCr, ""), " ", "")
tmpstr = Left(tmpstr, Len(tmpstr) - 1)
'MsgBox tmpstr
col2 = CInt(tmpstr)

tmpstr = ActiveDocument.Tables(1).Cell(4, 4).Range.Text
tmpstr = Replace(Replace(tmpstr, vbCr, ""), " ", "")
beforestr2 = Left(tmpstr, Len(tmpstr) - 1)

tmpstr = ActiveDocument.Tables(1).Cell(5, 4).Range.Text
tmpstr = Replace(Replace(tmpstr, vbCr, ""), " ", "")
afterstr2 = Left(tmpstr, Len(tmpstr) - 1)

Dim objFolder As Object
Set objFolder = objFso.GetFolder(path)

Dim i As Long

Dim f As Object
Dim objDoc As Object
For Each f In objFolder.Files
'拡張子にdocを含むものだけを対象にする
	If (InStr(f.Name, ".doc") > 0) Then
		'Wordファイルを開く
		Set objDoc = objWord.Documents.Open(FileName:=path & "\" & f.Name)
		For Each Section In objDoc.Sections
			If Section.Headers(1).Range.Tables.Count > 0 Then
				headerText = Section.Headers(1).Range.Tables(1).Cell(row1, col1).Range.Text
				verText = Section.Headers(1).Range.Tables(1).Cell(row2, col2).Range.Text
			Else
				'// ヘッダーが「1ページ目のみ別指定」にされている場合
				If Section.PageSetup.DifferentFirstPageHeaderFooter = True Then
					If Section.Headers(wdHeaderFooterFirstPage).Range.Tables.Count > 0 Then
						'// ヘッダーへ文字列を入力
						headerText = Section.Headers(wdHeaderFooterFirstPage).Range.Tables(1).Cell(row1, col1).Range.Text
						verText = Section.Headers(wdHeaderFooterFirstPage).Range.Tables(1).Cell(row2, col2).Range.Text
					Else
						headerText = ""
						verText = ""
					End If
				Else
					headerText = ""
					verText = ""
				End If
			End If
			If (headerText <> "") Then
				If (InStr(headerText, beforestr1) > 0) Then
					'最後の2文字を削除
					headerText = Left(headerText, Len(headerText) - 2)
					'MsgBox "セクション " & section.Index & " のヘッダー: " & vbCrLf & headerText
					headerText = Replace(headerText, beforestr1, afterstr1)
					'更新も行う設定にしている場合
					If replace_flag = 1 Then 
						If Section.PageSetup.DifferentFirstPageHeaderFooter = True Then
							 Section.Headers(wdHeaderFooterFirstPage).Range.Tables(1).Cell(row1, col1).Range.Text = headerText
						Else
							 Section.Headers(1).Range.Tables(1).Cell(row1, col1).Range.Text = headerText
						End If
						If (InStr(verText, beforestr2) > 0) Then
							 '最後の2文字を削除
							 verText = Left(verText, Len(verText) - 2)
							 verText = Replace(verText, beforestr2, afterstr2)
							 If Section.PageSetup.DifferentFirstPageHeaderFooter = True Then
								Section.Headers(wdHeaderFooterFirstPage).Range.Tables(1).Cell(row2, col2).Range.Text = verText
							 Else
								Section.Headers(1).Range.Tables(1).Cell(row2, col2).Range.Text = verText
							 End If
						 End If
					End If
				End If
			End If
		Next Section
		If objDoc.Saved = True Then
			'MsgBox "変更されていない場合、保存しない"
			objDoc.Close SaveChanges:=False
		'変更されている
		Else
			'MsgBox "変更されている場合、保存する"
			objDoc.Close SaveChanges:=True
		End If
	End If
Next f

objWord.Visible = False
Set objWord = Nothing

End Sub

サイトにのっけるからには再配置可能(リロケータブル)なプログラムにしているのですが、そのための主なポイントを2点述べます。

ポイント1､プログラム内に相対パスを記載しない

このコ－ドでは、相対パスを記載せず、エクルのセルに絶対パスを記載して、変数で取得するようにしている

念の為用語を確認しておくと以下の通りです。

• 絶対パス……自分自身を起点にしてファイルの位置を指定する
• 相対パス……C;のフォルダを起点にしてファイルの位置を指定する(Windowsの場合)

ダメな例を記載すると以下の通りです。

path = "./correct/"

相対パスを用いた書き方としては上記の書き方がある、この指定では、プログラムファイルと同じフォルダにあるcorrectという名前の読み込む形式になっているのだが､マクロを含むエクセルファイルを移動すると使えなくなってしまいます。

ポイント2､プログラムを動かすために必要なものは一つにまとめる

例えば本ページのコ－ドを動かすには、ソ－スと、エクセルの画面が必要になっています。

そのため、保存方法にも工夫が必要で、拡張子xlsmのファイルでエクセルシ－トと、ソ－スコ－ドをまとめて保存して使用されます。