一問一答の一歩

プログラムのバージョン変更などで、フォルダ全てのヘッダーに書いてある情報をまとめて変更したいとなった時があり、更新漏れがない事のチェックと、変更用のExcelVBAマクロを作成したので情報共有する。

本プログラムは以下のようなシ一トを前提としている

使い方は画像を見ての通りではあるが

• 手順1ラジオボタンで対象を選択する
• 手順2 チェックボックスのチェックによって変更箇所の確認なのか、変更も同時に行うのかを確認する。
• 手順3 検索、修正対象の文字列と変更後の文字列を入力する
• 手順4マクロを実行すると、エクセルシ一トに以下のように該当ファイル名と、検索、修正文字列こ一覧が表示される
• 手順5 修正も行った場合、該当のファイルが以下のように修正されている。

SUb Check_header_footer()
---------------------------------
'概要:指定フォルダ内のヘッター、フッターの値をエクセル内に表示
'機能名:Check_header_footer
'引数:なし
'戻り値:なし
'備考:
--------------------------------

	Const SHEET_NAME As Integer = 1
	Const HEADER As Integer = 2
	Const FOOTER As Integer = 3
	
	Const LEFT As Integer = 1
	Const CENTER As Integer = 2
	Const RIGHT As Integer = 3
	
	Dim myPath As String
	Dim myBook_name As String
	Dim kakutyoshi As String
	Dim mysheet As Worksheet
	Dim Changeobject As String
	Dim myHeader As String
	Dim myFooter As String
	Dim sheet_number As Long
	Dim replace_flag As Integer
	Dim object_number As Integer
	Dim header_place As Integer
	Dim footer_place As Integer
	
	
	'ヘッダーを調べるフォルダのパスを入力する。
	myPath = Thisworkbook.Worksheets(1).Cells(1,2).Value & "\"
	'拡張子に何も入力されていなかったらデフォルトでxlsxを設定
	If Thisworkbook.Worksheets(1).Cells(2,2).Value ="" Then
		kakutyoshi ="xlsx"
	Else 
		kakutyoshi = Thisworkbook.Worksheets(1).Cells(2,2).Value
	End If
	'パス配下拡張子「.xlsx」の最初の拡張子を返す。
	mybook_name = Dir(myPath & "*."& kakutyoshi)
		'book番号の初期化
	sheet_number = 1
	'選択対象オブジェクトの取得
	'object_number = Thisworkbook.Worksheets(1).Cells(5,2).Value
	If ThisWorkbook.Worksheets(1).OptionButton1.Value = True Then
		'修正対象をシート名に設定
		object_number = SHEET_NAME
	ElseIf ThisWorkbook.Worksheets(1).OptionButton2.Value = True Then
		'修正対象をヘッターに設定
		object_number = HEADER
	ElseIf ThisWorkbook.Worksheets(1).OptionButton3.Value = True Then
		'修正対象をフッターに設定
		object_number = FOOTER
	End If
	
	'使用するヘッダー位置を取得
	header_place = Thisworkbook.Worksheets(1).Cells(6,2).Value
	'使用するフッター位置を取得
	footer_place = Thisworkbook.Worksheets(1).Cells(7,2).Value
	
	'修正の有無の設定を取得する
	replace_flag = 0
	replace_flag = Thisworkbook.Worksheets(1).Cells(8,2).Value
	'replace_flag = ThisWorkbook.Worksheets(1).CheckBox1.Value
	
	'Dir関数がファイル名を返さなくなるまで繰り返す
	Do Until mybook_name = ""
		'ファイル名のブックを開く
		Workbooks.Open myPath & myBook_name
			For Each mySheet In Workbooks(myBook_name).Worksheets
				mysheet_name = mySheet.Name
				'検索対象のヘッダーの登録
				If header_place = CENTER Then
					myHeader = mySheet.PageSetup.CenterHeader
				ElseIf header_place = RIGHT Then
					myHeader = mySheet.PageSetup.RightHeader
				Else
					myHeader = mySheet.PageSetup.LeftHeader
				End If
				'検索対象のフッターの登録
				If footer_place = LEFT Then
					myFooter = mySheet.PageSetup.Leftfooter
				ElseIf footer_place = CENTER Then
					myFooter = mySheet.PageSetup.Centerfooter
				Else
					myFooter = mySheet.PageSetup.RightFooter
				End If
				
				
				'取得した文字列を一部加工
				myHeader = Replace(myHeader,"&A",mysheet_name)
				myFooter = Replace(myFooter,"&P","[現在のページ数]")
				myFooter = Replace(myFooter,"&N","[総ページ数]")
				
				ThisWorkbook.Worksheets(1).Cells(11 + sheet_number, 1 ).Value = mybook_name
				ThisWorkbook.Worksheets(1).Cells(11 + sheet_number, 2 ).Value = mysheet_name
				ThisWorkbook.Worksheets(1).Cells(11 + sheet_number, 3 ).Value = myHeader
				ThisWorkbook.Worksheets(1).Cells(11 + sheet_number, 4 ).Value = myFooter
				
				'シートの異常の確認
				'空白シートの有無の確認
				If (WorksheetFunction.CountA(mySheet.UsedRange) = 0) Then
					ThisWorkbook.Worksheets(1).Cells(11 + sheet_number, 5).Value = "空白シートの可能性あり"
					ThisWorkbook.Worksheets(1).Cells(11 + sheet_number,5).Interior.Color = RGB(255,255,0)
				End If
				
				'チェック、修正対象の設定を取得する
				If object_number = SHEET_NAME Then
					'修正対象をシート名に設定
					Changeobject = mySheet.Name
				ElseIf  object_number = HEADER Then
					'修正対象をヘッターに設定
					Changeobject = myHeader
				ElseIf  object_number = FOOTER Then
					'修正対象をフッターに設定
					Changeobject = myFooter
				End If
				
				
				'検索対象の文字列が入力されている場合
				If ThisWorkbook.worksheets(1).Cells(3,2).Value<>"" Then
					'検索,修正対象にチェックしたい文言が含まれていることの確認
					If Instr(Changeobject , ThisWorkbook.Worksheets(1).Cells(3 , 2).Value) = 0 Then
						If replace_flag = 0 Then
							'チェックのみの場合,ワードがヘッダーに含まれていなかったら黄色く強調する
							ThisWorkbook.Worksheets(1).Cells(11 + sheet_number, object_number + 1 ).Interior.Color = RGB(255,255,0)
						End If
					ElseIf replace_flag <> 0 Then
						'チェックしたワードがヘッダーに含まれており、なおかつ修正も行う設定にしていた場合は値の修正も行う
						'値の修正
						Changeobject = Replace(Changeobject, ThisWorkbook.Worksheets(1).Cells(3, 2).Value, ThisWorkbook.Worksheets(1).Cells(4, 2).Value)
						If object_number = SHEET_NAME Then
							'修正対象をシートに書き込む
							mysheet.Name=Changeobject
						ElseIf object_number = HEADER Then
							'修正対象をヘッターに書き込む
							If header_place = CENTER Then
								mySheet.PageSetup.CenterHeader = Changeobject
							ElseIf header_place = RIGHT Then
								mySheet.PageSetup.RightHeader = Changeobject
							Else
								mysheet.Pagesetup.Leftheader = Changeobject
							End If
						ElseIf object_number = FOOTER Then
							'修正対象をフッターに書き込む
							If footer_place = LEFT Then
								mySheet.PageSetup.Leftfooter = Changeobject
							ElseIf footer_place = CENTER Then
								mySheet.PageSetup.Centerfooter = Changeobject
							Else
								mySheet.PageSetup.RightFooter = Changeobject
							End If
						End If
						'修正を行う場合、修正対象になったもののみ黄色く染める
						ThisWorkbook.Worksheets(1).Cells(11 + sheet_number, object_number + 1 ).Interior.Color = RGB(255,255,0)
					End If
				End If
				
				
				'sheet番号を1増やす
				sheet_number = sheet_number+1
			Next mysheet
			'ブックが変更されていない場合、保存せずに閉じる
			IF Workbooks(mybook_name).Saved = True Then
				Workbooks(mybook_name).Close SaveChanges := False
			'ブックが変更されている場合、保存して閉じる
			Else
				Workbooks(mybook_name).Close SaveChanges := True
			End If
			mybook_name = Dir 	'引数なしDir……引数を引き継いだ次のファイル名を返す。
	Loop
End Sub