Un Known…(跡地) 技術メモ

Dir関数を用いるため、ネットワーク上の長いファイルパスには未対応です。

Sub Test() 
    ' 検索速度向上のポイント
    ' 何度も登場するブックやセルは変数に格納し、メモリを参照する。
    ' 画面チラつきを防止する。

    ' 画面チラつきを防止する。
    Application.ScreenUpdating = False

    ' フォルダパスとファイル名を宣言する。
    Dim strFilePath As String
    Dim strFileNmae As String
         
    ' テキストボックスかセル入力でフォルダを指定させる。
    strFilePath = "C:\Users\test\Desktop\テストディレクトリ"
    
    ' 末尾が\ではない場合、\を追加する。(未実装)
    strFilePath = strFilePath & "\"
    
    ' 指定フォルダ内のファイル名を取得する。
    strFileName = Dir(strFilePath, vbNormal)

    ' 結果シートを変数に設定する。
    Dim resultBookSheet As Worksheet
    Set resultBookSheet = Worksheets("sheet1")
   
    ' 結果シートの行数を宣言する。
    Dim longGyo As Long
    longGyo = 1

    ' 指定フォルダ内のファイルがなくなるまで繰り返す。
    Do While strFileName <> ""

        Dim result As Range
        Dim firstAddress As String

        ' ファイルを開く。
        With Workbooks.Open(Filename:=strFilePath & strFileName)

            ' ファイル内のシート数を取得する。
            Dim sheetCnt As Long
            sheetCnt = .Worksheets.Count
           
            ' 1シート目からnシート目まで繰り返す。
            Dim i As Long
            For i = 1 To sheetCnt
                ' What:=検索するデータを指定
                ' After:=検索を開始するセルを指定
                ' LookIn:=値を検索
                ' LookAt:=一部が一致するセルを検索
                ' SearchOrder:=列単位で検索(行単位のxlByColumnsを指定しているとセル結合が検索されない)
                ' SearchDirection:=順方向に検索
                ' MatchCase:=大文字と小文字を区別しない
                ' MatchByte:=半角と全角を区別しない
                ' SearchFormat:=セル書式は検索条件に指定しない
                Set result = .Worksheets(i).Cells.Find(What:="APS" _
                    , After:=ActiveCell _
                    , LookIn:=xlValues _
                    , LookAt:=xlPart _
                    , SearchOrder:=xlByRows _
                    , SearchDirection:=xlNext _
                    , MatchCase:=False _
                    , MatchByte:=False _
                    , SearchFormat:=False)
               
                If Not result Is Nothing Then
                    firstAddress = result.Address
                    Do
                        resultBookSheet.Cells(longGyo, 1).Value = strFilePath & strFileName
                        resultBookSheet.Cells(longGyo, 2).Value = .Worksheets(i).Name
                        ' resultBookSheet.Cells(longGyo, 3).Value = "セル(" & result.Row & ", " & result.Column & ")"
                        resultBookSheet.Cells(longGyo, 3).Value = "セル(" & result.Address & ")"
                        resultBookSheet.Cells(longGyo, 4).Value = .Worksheets(i).Cells(result.Row, result.Column).Value
                        longGyo = longGyo + 1
                        Set result = .Worksheets(i).Cells.FindNext(result)
                        If result Is Nothing Then
                            Exit Do
                        End If
                        If result.Address = firstAddress Then
                            Exit Do
                        End If
                    Loop
                End If
            Next i
            
            ' 保存せずファイルを閉じる。
            .Close SaveChanges:=False
        End With

        ' 次のファイルを取得する。
        strFileName = Dir()
    Loop
        
    ' 画面チラつき防止を解除する。
    Application.ScreenUpdating = True
    
End Sub