フォルダ内の特定文字が含まれるエクセル検索

Option Explicit

Sub SearchExcelFiles()
    Dim folderPath As String
    Dim searchText As String
    Dim includeSubfolders As Boolean
    Dim startTime As Double
    Dim estimatedTime As Double
    Dim newWb As Workbook
    Dim ws As Worksheet
    Dim rowNum As Long
    
    ' フォルダ選択オプション
    folderPath = InputBox("検索するフォルダのパスを入力（空の場合は選択ダイアログを使用）:")
    If folderPath = "" Then
        With Application.FileDialog(msoFileDialogFolderPicker)
            .Title = "検索するフォルダを選択"
            If .Show = -1 Then
                folderPath = .SelectedItems(1)
            Else
                Exit Sub
            End If
        End With
    End If
    
    searchText = InputBox("検索する文字を入力:")
    If searchText = "" Then Exit Sub
    
    includeSubfolders = (MsgBox("サブフォルダーも検索しますか?", vbYesNo) = vbYes)
    
    ' 予測時間計算 (仮の計算: 1ファイルあたり0.5秒)
    Dim fileCount As Long
    fileCount = CountExcelFiles(folderPath, includeSubfolders)
    estimatedTime = fileCount * 0.5
    MsgBox "予測時間: " & Round(estimatedTime, 2) & " 秒", vbInformation
    
    ' 新しいブックを作成
    Set newWb = Workbooks.Add
    Set ws = newWb.Sheets(1)
    ws.Name = "検索結果"
    
    ' ヘッダーの作成とスタイル設定
    With ws
        .Cells(1, 1).Value = "ブック名"
        .Cells(1, 2).Value = "リンク"
        .Cells(1, 3).Value = "セルの文字"
        .Cells(1, 4).Value = "セルアドレス"
        .Cells(1, 5).Value = "フルパス"
        .Cells(1, 6).Value = "開いているユーザー"
        .Cells(1, 7).Value = "PC名"
        .Cells(1, 8).Value = "OS名"
        .Cells(1, 9).Value = "ユーザー名"
        .Rows(1).Font.Bold = True
        .Rows(1).Interior.Color = RGB(0, 112, 192)
        .Rows(1).Font.Color = RGB(255, 255, 255)
        .Columns.AutoFit
    End With
    
    rowNum = 2
    
    ' 検索開始
    startTime = Timer
    SearchFiles folderPath, searchText, includeSubfolders, ws, rowNum
    
    ' 列幅の自動調整
    ws.Columns.AutoFit
    
    MsgBox "検索完了! 所要時間: " & Round(Timer - startTime, 2) & " 秒", vbInformation
End Sub

Function CountExcelFiles(ByVal folderPath As String, ByVal includeSubfolders As Boolean) As Long
    Dim fso As Object, folder As Object, file As Object, subFolder As Object
    Dim count As Long
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(folderPath)
    
    ' ファイルカウント
    For Each file In folder.Files
        If LCase(Right(file.Name, 5)) = ".xlsx" Or LCase(Right(file.Name, 4)) = ".xls" Then
            count = count + 1
        End If
    Next file
    
    ' サブフォルダー処理
    If includeSubfolders Then
        For Each subFolder In folder.SubFolders
            count = count + CountExcelFiles(subFolder.Path, True)
        Next subFolder
    End If
    
    CountExcelFiles = count
End Function

Sub SearchFiles(ByVal folderPath As String, ByVal searchText As String, ByVal includeSubfolders As Boolean, ByVal ws As Worksheet, ByRef rowNum As Long)
    Dim fso As Object, folder As Object, file As Object, subFolder As Object
    Dim wb As Workbook, wsSheet As Worksheet
    Dim cell As Range
    Dim fullPath As String
    Dim userName As String
    Dim pcName As String
    Dim osName As String
    Dim currentUser As String
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(folderPath)
    
    pcName = Environ("COMPUTERNAME")
    osName = Environ("OS")
    currentUser = Environ("USERNAME")
    
    Application.ScreenUpdating = False ' 高速化
    
    ' ファイルをループ
    For Each file In folder.Files
        If LCase(Right(file.Name, 5)) = ".xlsx" Or LCase(Right(file.Name, 4)) = ".xls" Then
            fullPath = file.Path
            userName = GetFileOwner(fullPath) ' 開いているユーザー名取得
            On Error Resume Next
            Set wb = Workbooks.Open(fullPath, ReadOnly:=True, UpdateLinks:=False)
            If Err.Number <> 0 Then
                Err.Clear
                On Error GoTo 0
                GoTo NextFile
            End If
            On Error GoTo 0
            
            ' 各シートをループして検索
            For Each wsSheet In wb.Sheets
                For Each cell In wsSheet.UsedRange
                    If InStr(1, cell.Value, searchText, vbTextCompare) > 0 Then
                        ws.Cells(rowNum, 1).Value = file.Name
                        ws.Hyperlinks.Add Anchor:=ws.Cells(rowNum, 2), Address:=fullPath, TextToDisplay:="開く"
                        ws.Cells(rowNum, 3).Value = cell.Value
                        ws.Cells(rowNum, 4).Value = cell.Address
                        ws.Cells(rowNum, 5).Value = fullPath
                        ws.Cells(rowNum, 6).Value = userName
                        ws.Cells(rowNum, 7).Value = pcName
                        ws.Cells(rowNum, 8).Value = osName
                        ws.Cells(rowNum, 9).Value = currentUser
                        rowNum = rowNum + 1
                    End If
                Next cell
            Next wsSheet
            
            wb.Close False
        End If
NextFile:
    Next file
    
    ' サブフォルダー処理
    If includeSubfolders Then
        For Each subFolder In folder.SubFolders
            SearchFiles subFolder.Path, searchText, True, ws, rowNum
        Next subFolder
    End If
    
    Application.ScreenUpdating = True ' 画面更新再開
End Sub

Function GetFileOwner(ByVal filePath As String) As String
    Dim objShell As Object, objFolder As Object, objFile As Object
    Dim owner As String
    
    On Error Resume Next
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(Left(filePath, InStrRev(filePath, "\\") - 1))
    Set objFile = objFolder.ParseName(Right(filePath, Len(filePath) - InStrRev(filePath, "\\")))
    owner = objFile.GetDetail(8) ' プロパティインデックス8: 所有者
    GetFileOwner = owner
    On Error GoTo 0
End Function