一問一答の一歩

仕事でエクセルの書類の作成を行う機会があったのだが、フォルダ内全てのファイルとなると、人力でエラーの部分の確認と修正も手間がかかるため、ExcelVBAにより作成したセルの確認と修正ツールを共有する。

本プログラムでは、以下のワ－クシ－トを前提とする。

以下のように、入力したフォルダパスの内部に複数のエクセルファイルがある時に、全てのエクセルファイルに対して検索対象の文字を含むセルがあった場合には、書き換えを行う。

Sub replace_cell()
'----------------------------------------------
'概要: 指定したフォルダ内のテキストボックス内にを指定した文字列が含まれているかを確認する
'機能名: CheckTextBox
'引数: なし
'戻り値: なし
'備考:指定した文字がテキストボックスに含まれているファイルを検索する
'----------------------------------------------

	Dim myPath As String
	Dim kakutyoshi As String
	Dim search_str As String
	Dim replace_str As String
	Dim myBook_name As String
	Dim mySheet_name As String
	Dim book_number As Long
	Dim row_number As Integer
	Dim column_number As Integer
	Dim replace_flag As Integer

	myPath = ThisWorkbook.Worksheets(1).Cells(1, 2).Value & "\\"
	kakutyoshi = ThisWorkbook.Worksheets(1).Cells(2, 2).Value
	search_str = ThisWorkbook.Worksheets(1).Cells(3, 2).Value
	replace_str = ThisWorkbook.Worksheets(1).Cells(4, 2).Value
	'拡張子に値が設定されていなかったらデフォルトでxlsxをセット
	If kakutyoshi = "" Then
		kakutyoshi = "xlsx"
	End If
	'値の修正は行わないものと設定する
	replace_flag = 0
	'パス配下の設定した拡張子の最初のファイル名を返す
	myBook_name = Dir(myPath & "*" & kakutyoshi)
	book_number = 1
	'Dir関数がファイル名を返さなくなるまで繰り返す
	Do Until myBook_name = ""
		'ファイル名のブックを開く
		Workbooks.Open myPath & myBook_name
		For Each mySheet In Workbooks(myBook_name).Worksheets
			For row_number = 1 TO mySheet.Cells(Rows.Count,1).End(xlup).Row
				For column_number = 1 TO mySheet.Cells(Columns.Count,1).End(xlToLeft).Column
					If InStr(mySheet.Cells(row_number , column_number).Value, search_str) > 0 Then
						'1列目のセルにファイル名を書き込み
						ThisWorkbook.Worksheets(1).Cells(book_number + 9, 1).Value = myBook_name
						'2列目のセルにシート名を書き込み
						ThisWorkbook.Worksheets(1).Cells(book_number + 9, 2).Value = mySheet.name
						'3列目のセルに該当テキストを書き込み
						ThisWorkbook.Worksheets(1).Cells(book_number + 9, 3).Value = mySheet.Cells(row_number , column_number).Value
						If replace_flag <> 0 Then
							'検索した文字列の書き換え
							mySheet.Cells(row_number , column_number).Value = Replace(mySheet.Cells(row_number , column_number).Value, search_str, replace_str)
						End If
						'book番号を1増やす
						book_number = book_number + 1
					END IF
				Next column_number
			Next row_number
		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
	Loop

End Sub