一問一答の一歩

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

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

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

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

SUb Check_header_footer()
---------------------------------
'概要:指定フォルダ内のヘッター、フッターの値をエクセル内に表示
'機能名:Check_header_footer
'引数:なし
'戻り値:なし
'備考:
--------------------------------
	DIm myPath As String
	DIm myBook_name As String
	Dim mysheet As Worksheeet
	Dim Myheader As String
	Dim Myfooter As String
  	Dim kakutyushi As String
	Dim sheet_number As Long
	Dim replace_flag As Long
	Dim object_number As Integer

	'ページを調べるフォルダのパスをB2に入力する
	myPath=ThisWorkbook.Worksheets(1).Cells(1,2).Value & "\\"
	kakutyoshi=ThisWorkbook.Worksheets(1).Cells(2,2).Value
	'拡張子に何もセットされていなかったらデフォルトでxlsxをセット
	If kakutyoshi="" THEN
		kakutyoshi="xlsx"
	End IF
	'設定した拡張子の最初のファイルを返す。
	mybook_name=Dir(myPath & "*." & kakutyoshi)

	sheet_number=1

	'Dir関数がファイル名を返さなくなるまで繰り返す。
	Do Until myBook_name=""
		'ファイル名のブックを開く
		Workbooks.Open myPath & myBook_name
		'開いたブックで処理をする

		For Each mysheet.In Workbooks(myBook_name).Worksheets
			mysheet_name=mysheet.Name
			myheader=mysheet.PageSetup.LeftHeader
			myfooter=mysheet.PageSetup.RightFooter

			'取得した文字列を一部加工
			myheader=Replace(myhaeder,"&A",mysheets_name)
			myfooter=Replace(myfooter,"&P","[現在のページ数]")
			myfooter=Replace(myfooter,"&N","[総ページ数]")
			'A6,B6,C6,D6にそれぞれファイル名、シート名、ヘッター、フッターのデータを登録する
			ThisWorkbook.Worksheets(1).Cells(10+sheet_number,1).value=myBook_name
			ThisWorkbook.Worksheets(1).Cells(10+sheet_number,2).value=mysheet_name
			ThisWorkbook.Worksheets(1).Cells(10+sheet_number,3).value=myheader
			ThisWorkbook.Worksheets(1).Cells(10+sheet_number,4).value=myfooter

		'空白シートの有無の確認
			If(WorksheetFunction.countA(mySheet.UsedRange)=0) Then
				ThisWorkbook.Worksheets(1).Cells(10+sheet_number,5).value="空白シートの可能性あり"
				ThisWorkbook.Worksheets(1).Cells(10+sheet_number,5).Interior.Color=RGB(255,255,0)
			End If
			replace_flag = 0
			'チェック､修正対象の取得をする
			If Thisworkbooks.Workshets(1).OptionButtton1.Value=True Then
				Changeobject = mysheeet.Name
				object_number = 1
			ElseIf Thisworkbooks.Workshets(1).OptionButtton2.Value=True
				Changeobject = myheader
				object_number = 2
			ElseIf Thisworkbooks.Workshets(1).OptionButtton3.Value=True
				Changeobject = myfooter
				object_number = 3
			End If

			'ヘッダー内に､B3のセルの記載内容の文言が含まれていることの確認
			If ThissWorkbook.Worksheets(1).Cells(3,2).value<>"" Then
				If Instr(Changeobject , ThisWorkbook.Worksheets(1).Cells(2,2),Value)=0 Then
					If  replace_flag = 0 Then
						'セルを黄色く染める
						ThisWorkbook.Worksheets(1).Cells(6+sheets_number,3).Interior.Color=RGB(255,255,0)
					End If
					'検索ワードがあり、なおかつ修正も行う設定にしていた場合
				ElseIf replace_flag <>0 Then
					'値の修正
					Changeobject=Replace(Changeobject,ThissWorkbook.Worksheets(1).Cells(3,2).value,ThissWorkbook.Worksheets(1).Cells(4,2).value)
					If Thisworkbooks.Workshets(1).OptionButtton1.Value=True
						'修正対象をシ－トに書き込む
						mysheeet.Name=Changeobject
					ElseIf Thisworkbooks.Workshets(1).OptionButtton2.Value=True
						mysheet.PageSetup.LeftHeader=Changeobject
					ElseIf Thisworkbooks.Workshets(1).OptionButtton3.Value=True
						mysheet.PageSetup.RightFooter=Changeobject
					End If
					'セルを黄色く染める
					ThisWorkbook.Worksheets(1).Cells(6+sheets_number,3).Interior.Color=RGB(255,255,0)	
				End If
			End If

			'sheet_numberを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
		'引数なしDir……引数を引き継いだ次のファイル名を返す
		myBook_name=Dir
	Loop
End Sub