Excel分析ツール - 1727829785 - したらば掲示板

1：名無しさん：2024/10/02(水) 09:43:05: Excel分析ツール
2：名無しさん：2024/10/02(水) 09:45:38: '--------------------------------------------------------
' 指定フォルダ内の全てのブックから任意の文字列を検索する
'--------------------------------------------------------
' https://excel.syogyoumujou.com/vba/find_allbooks.html
'--------------------------------------------------------
Sub searchAllBooksForAnyString() 'メイン
'--------------------------------
' 検索する文字列を配列として設定
'--------------------------------
Dim varArray As Variant
varArray = Array("富山", "神奈川") '検索文字列

'--------------------------------
' フォルダの選択
'--------------------------------
Dim strFolderPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then strFolderPath = .SelectedItems(1)
End With
If Len(strFolderPath) = 0 Then Exit Sub

'--------------------------------
' フォルダの存在確認
'--------------------------------
If Dir(strFolderPath, vbDirectory) = "" Then
MsgBox "対象のフォルダが見つかりません", vbExclamation, "終了します"
Exit Sub
End If

'--------------------------------
' フォルダ内ブックを検索
'--------------------------------
Dim strFileName As String
strFolderPath = strFolderPath & Application.PathSeparator 'フォルダパスに区切り文字追加
strFileName = Dir(strFolderPath & "*.xls?") 'フォルダからExcelブックを検索
If strFileName = "" Then 'ブックのパスを取得できなければ終了
MsgBox "指定フォルダ内にExcelブックが見つかりません", vbExclamation, "終了します"
Exit Sub
End If

Application.ScreenUpdating = False '画面更新無効
Application.EnableEvents = False 'イベント無効

'--------------------------------
' 新規ブック追加・見出し設定
'--------------------------------
Dim shtWrite As Worksheet '書き込みシート
Set shtWrite = Workbooks.Add.Worksheets(1)
shtWrite.Range("A4:C4").Value = Array("検索値", "ブック名", "シート名")
shtWrite.Range("1:1,4:4").Interior.Color = RGB(217, 225, 242)
3：名無しさん：2024/10/02(水) 09:46:32: '--------------------------------
' ブック内から文字列を検索
'--------------------------------
Dim bokTarget As Workbook
Dim shtTarget As Worksheet
Dim rngTarget As Range
Dim varWhat As Variant
Dim lngCount As Long
On Error Resume Next
Do
'フォルダ内のブックを開く
Set bokTarget = Workbooks.Open(strFolderPath & strFileName)

'--------------------------------
'ブックの各シートで検索を実行
'--------------------------------
For Each shtTarget In bokTarget.Worksheets
For Each varWhat In varArray
'対象シートの全てのセルから任意の文字列を検索
Set rngTarget = findTargetCell(shtTarget.Cells, varWhat)

'検索に一致するセルが存在する場合は新規ブックに情報を書き込み
If Not rngTarget Is Nothing Then
With shtWrite.Cells(5 + lngCount, "A").Resize(1, 4)
.Value = Array(varWhat, bokTarget.Name, shtTarget.Name, rngTarget.Address(0, 0))
lngCount = lngCount + 1
End With
End If
Next
Next

'開いたブックを保存せずに閉じる
bokTarget.Close SaveChanges:=False

strFileName = Dir() '次のExcelブックを検索
Loop Until strFileName = "" 'ブックが見つからなければループから抜ける

strFileName = Dir("")
On Error GoTo 0

'--------------------------------
' 検索値が見つからなければ終了
'--------------------------------
If lngCount = 0 Then
shtWrite.Parent.Close SaveChanges:=False
MsgBox "検索値は見つかりませんでした", vbInformation
GoTo LBL_FINALLY
End If