はじめに
久しぶりにVBAでプログラミングをしてみました。
@es2さんの作成されたモジュールをベースに（流用）させていただきました。
まだ、レビュー＆テストは不十分です・・・
仕様
特定のフォルダ以下に格納されているExcelファイルから、データを収集する。
データを収集するときに、以下を指定できるようにする。
- ファイル名（ワイルドカード使用可）
- シート名
- セルタイトルと合致したセルからのオフセット
セルタイトルに合致するセルは、シート内に一か所のみの前提
UI
3行目以下が結果出力部
上記イメージの入力となったファイル
コード
@zarukishi さんに2回レビューしていただいて、2回修正しました。
ソースコード Ver1.00
' フォルダパスと検索するファイル名（ワイルドカード使用可）を定義
Const SEARCH_FOLDER As String = "C:\Users\"
Const FILE_SEARCH_PATTERN As String = "*_test.xlsx"
' ファイル取得処理用のサブ関数（GetFilesForAllDirectories）で利用する変数
Private Filedic As Object 'Dictionary , 参照:Microsoft Scripting Runtime
' データ収集時の検索のキーとなる情報を格納するための構造体
Private Type ScrapingKey
sheetName As String
cellTitle As String
offsetX As Integer
offsetY As Integer
End Type
' 処理本体
' Excelファイル内の表構成やデータ収集の処理方法を変える場合、修正が必要
Public Sub ScrapingExcelFileData()
Dim thisWS As Worksheet
Set thisWS = ThisWorkbook.ActiveSheet
Dim targetWB As Workbook
Dim row, col, i As Integer
Dim files: files = GetFilesForAllDirectories(SEARCH_FOLDER, FILE_SEARCH_PATTERN)
Dim file
' データ収集時の検索のキーとなる情報を配列に格納
' キーとなる情報は、"SheetName:CellTitle:OffsetX:OffsetY"で表現されている前提の処理
Dim scrapingKeys() As ScrapingKey
Dim scrapingKeyString As String
Dim tmp As Variant
col = 3
i = 0
Do While (thisWS.Cells(2, col) <> "")
ReDim Preserve scrapingKeys(i)
scrapingKeyString = thisWS.Cells(2, col)
tmp = Split(scrapingKeyString, ":")
scrapingKeys(i).sheetName = tmp(0)
scrapingKeys(i).cellTitle = tmp(1)
scrapingKeys(i).offsetX = tmp(2)
scrapingKeys(i).offsetY = tmp(3)
col = col + 1
i = i + 1
Loop
' データ収集結果の出力処理
Application.ScreenUpdating = False
Dim beforeCalculation As Variant
beforeCalculation = Application.Calculation
Application.Calculation = xlCalculationManual
row = 3
For Each file In files
thisWS.Cells(row, 1) = file.Path
thisWS.Cells(row, 2) = file.DateLastModified
Set targetWB = Workbooks.Open(thisWS.Cells(row, 1), ReadOnly:=True)
col = 3
For i = 0 To UBound(scrapingKeys)
thisWS.Cells(row, col + i) = GetDataFromTargetWB(targetWB, scrapingKeys(i).sheetName, scrapingKeys(i).cellTitle, scrapingKeys(i).offsetX, scrapingKeys(i).offsetY)
Next
row = row + 1
targetWB.Close
Next
Application.ScreenUpdating = True
Application.Calculation = beforeCalculation
End Sub
Public Function GetDataFromTargetWB(targetWB As Workbook, sheetName As String, cellTitle As String, offsetX As Integer, offsetY As Integer) As String
Dim targetWS As Worksheet
Set targetWS = targetWB.Sheets(sheetName)
If targetWS Is Nothing Then
MsgBox "シートの検索に失敗しました"
Else
Dim FoundCell As Range
Set FoundCell = targetWS.Cells.Find(cellTitle)
If FoundCell Is Nothing Then
MsgBox "セルタイトルの検索に失敗しました"
Else
GetDataFromTargetWB = FoundCell.Offset(offsetY, offsetX).Value
End If
End If
End Function
'@es2さんの作成されたモジュールをベースに正規表現ではなくワイルドカードしか使えない処理に変更
'https://qiita.com/es2/items/eeb3a02891ff50b6dabc
Public Function GetFilesForAllDirectories(currentFolder As String, fileNamePattern As String) As Variant
Set Filedic = CreateObject("scripting.dictionary") 'New Dictionary(Microsoft Scripting Runtimeが有効な場合)
Call GetFilePath(currentFolder, fileNamePattern)
GetFilesForAllDirectories = Filedic.Keys
End Function
Private Function GetFilePath(folderPath As String, fileNamePattern As String) As Variant
Dim fso As Object: Set fso = CreateObject("scripting.Filesystemobject") ' New FileSystemObject (Microsoft Scripting Runtimeが有効な場合)
Dim subfolder As Object 'Folder(Microsoft Scripting Runtimeが有効な場合)
For Each subfolder In fso.GetFolder(folderPath).SubFolders
Call GetFilePath(subfolder.Path, fileNamePattern)
Next
Dim file 'as Fileとしたいですが for eachで帰ってくる要素はVariant限定なのでas Fileはデバッグ以外で使用できません
For Each file In fso.GetFolder(folderPath).files
If file.Path Like fileNamePattern Then
Filedic.add file, 0
End If
Next
End Function
レビュー指摘 1回目
- Private Filedic As Objectは、（モジュール内）グローバル変数宣言すべきでない
- GetFilesForAllDirectories()のローカル変数で十分
- GetFilePath()の引数に参照渡しすべき（引数記述でのByRefは省略可）
- Private Function GetFilePath()は何もReturnしていない、Subでよい
- GetFilePath()でのLikeは大文字・小文字を無視しない
- Const FILE_SEARCH_PATTERN As String = "*_test.xlsx"なので、testやxlsxの部分が大文字だとヒットしない
- Public Sub ScrapingExcelFileData()の行番号変数は、本来Longにすべき（今のままでも動く）
- Dim row, col, i As Integerとは、row As Variant, col As Variant, i As Integerと宣言している
- Integerは32767までだが、Excelの行番号は、それ以上に動く
- Variantなので、今のままでもセーフ
- 列番号や i も全部Longのほうが楽
- ScrapingKey構造体や、関数GetDataFromTargetWB()の引数に出てくる、offsetY（、offsetX）も同様
- Dim beforeCalculation As Variantは本来、As XlCalculation（今のままでも動く）
- Public Function GetDataFromTargetWB()の冒頭If文は、各PCの設定次第では危険
- On Error Resume Next宣言がグローバルにも、関数単体にもないので、例外発生時の動きは（各PCの設定）次第
- 少し後ろにあるCells.Find()の失敗も、同様かも
ソースコード Ver2.00
' フォルダパスと検索するファイル名（ワイルドカード使用可）を定義
Const SEARCH_FOLDER As String = "C:\Users\"
Const FILE_SEARCH_PATTERN As String = "*_test.xlsx"
' データ収集時の検索のキーとなる情報を格納するための構造体
Private Type ScrapingKey
sheetName As String
cellTitle As String
offsetX As Long
offsetY As Long
End Type
' 処理本体
' Excelファイル内の表構成やデータ収集の処理方法を変える場合、修正が必要
Public Sub ScrapingExcelFileData()
Dim thisWS As Worksheet
Set thisWS = ThisWorkbook.ActiveSheet
Dim targetWB As Workbook
Dim row, col, i As Long
Dim files: files = GetFilesForAllDirectories(SEARCH_FOLDER, FILE_SEARCH_PATTERN)
Dim file
' データ収集時の検索のキーとなる情報を配列に格納
' キーとなる情報は、"SheetName:CellTitle:OffsetX:OffsetY"で表現されている前提の処理
Dim scrapingKeys() As ScrapingKey
Dim scrapingKeyString As String
Dim tmp As Variant
col = 3
i = 0
Do While (thisWS.Cells(2, col) <> "")
ReDim Preserve scrapingKeys(i)
scrapingKeyString = thisWS.Cells(2, col)
tmp = Split(scrapingKeyString, ":")
scrapingKeys(i).sheetName = tmp(0)
scrapingKeys(i).cellTitle = tmp(1)
scrapingKeys(i).offsetX = tmp(2)
scrapingKeys(i).offsetY = tmp(3)
col = col + 1
i = i + 1
Loop
' データ収集結果の出力処理
Application.ScreenUpdating = False
Dim beforeCalculation As XlCalculation
beforeCalculation = Application.Calculation
Application.Calculation = xlCalculationManual
row = 3
For Each file In files
thisWS.Cells(row, 1) = file.Path
thisWS.Cells(row, 2) = file.DateLastModified
Set targetWB = Workbooks.Open(thisWS.Cells(row, 1), ReadOnly:=True)
col = 3
For i = 0 To UBound(scrapingKeys)
thisWS.Cells(row, col + i) = GetDataFromTargetWB(targetWB, scrapingKeys(i).sheetName, scrapingKeys(i).cellTitle, scrapingKeys(i).offsetX, scrapingKeys(i).offsetY)
Next
row = row + 1
targetWB.Close
Next
Application.ScreenUpdating = True
Application.Calculation = beforeCalculation
End Sub
Public Function GetDataFromTargetWB(targetWB As Workbook, sheetName As String, cellTitle As String, offsetX As Long, offsetY As Long) As String
Dim targetWS As Worksheet
Set targetWS = Nothing
On Error Resume Next
Set targetWS = targetWB.Sheets(sheetName)
If targetWS Is Nothing Then
MsgBox "シートの検索に失敗しました"
Else
Dim foundCell As Range
Set foundCell = Nothing
Set foundCell = targetWS.Cells.Find(cellTitle)
If foundCell Is Nothing Then
MsgBox "セルタイトルの検索に失敗しました"
Else
GetDataFromTargetWB = foundCell.Offset(offsetY, offsetX).Value
End If
End If
End Function
'@es2さんの作成されたモジュールをベースに正規表現ではなくワイルドカードしか使えない処理に変更
'https://qiita.com/es2/items/eeb3a02891ff50b6dabc
Public Function GetFilesForAllDirectories(currentFolder As String, fileNamePattern As String) As Variant
Dim filedic As Object 'Dictionary , 参照:Microsoft Scripting Runtime
Set filedic = CreateObject("scripting.dictionary") 'New Dictionary(Microsoft Scripting Runtimeが有効な場合)
Call GetFilePath(currentFolder, fileNamePattern, filedic)
GetFilesForAllDirectories = filedic.Keys
End Function
Private Sub GetFilePath(folderPath As String, fileNamePattern As String, ByRef filedic As Object)
Dim fso As Object: Set fso = CreateObject("scripting.Filesystemobject") ' New FileSystemObject (Microsoft Scripting Runtimeが有効な場合)
Dim subfolder As Object 'Folder(Microsoft Scripting Runtimeが有効な場合)
For Each subfolder In fso.GetFolder(folderPath).SubFolders
Call GetFilePath(subfolder.Path, fileNamePattern, filedic)
Next
Dim file 'as Fileとしたいですが for eachで帰ってくる要素はVariant限定なのでas Fileはデバッグ以外で使用できません
For Each file In fso.GetFolder(folderPath).files
If LCase(file.Path) Like LCase(fileNamePattern) Then
filedic.add file, 0
End If
Next
End Sub
レビュー指摘 2回目
- 指摘済み：Dim row, col, i As Integerとは、row As Variant, col As Variant, i As Integerと宣言している
- 対応しきれていない（宣言を個別にするべき）
Dim row As Long
Dim col As Long
Dim i As Long - 追加指摘：ファイル検索は、定数定義（FILE_SEARCH_PATTERN）の意図と異なる。現状は、ファイル名パターンが「*」始まりなので助かっている。
- If LCase(file.Path) Like LCase(fileNamePattern) Then ではない
If LCase(file.Name) Like LCase(fileNamePattern) Then とすべき
ソースコード Ver3.00
' 本プログラムは、Microsoft Scripting Runtimeを有効にして使用する
' フォルダパスと検索するファイル名（ワイルドカード使用可）を定義
Const SEARCH_FOLDER As String = "C:\Users\"
Const FILE_SEARCH_PATTERN As String = "*_test.xlsx"
' データ収集時の検索のキーとなる情報を格納するための構造体
Private Type ScrapingKey
sheetName As String
cellTitle As String
offsetX As Long
offsetY As Long
End Type
' 処理本体
' Excelファイル内の表構成やデータ収集の処理方法を変える場合、修正が必要
Public Sub ScrapingExcelFileData()
Dim thisWS As Worksheet
Set thisWS = ThisWorkbook.ActiveSheet
Dim targetWB As Workbook
Dim row As Long
Dim col As Long
Dim i As Long
Dim files: files = GetFilesForAllDirectories(SEARCH_FOLDER, FILE_SEARCH_PATTERN)
Dim file
' データ収集時の検索のキーとなる情報を配列に格納
' キーとなる情報は、"SheetName:CellTitle:OffsetX:OffsetY"で表現されている前提の処理
Dim scrapingKeys() As ScrapingKey
Dim scrapingKeyString As String
Dim tmp As Variant
col = 3
i = 0
Do While (thisWS.Cells(2, col) <> "")
ReDim Preserve scrapingKeys(i)
scrapingKeyString = thisWS.Cells(2, col)
tmp = Split(scrapingKeyString, ":")
scrapingKeys(i).sheetName = tmp(0)
scrapingKeys(i).cellTitle = tmp(1)
scrapingKeys(i).offsetX = tmp(2)
scrapingKeys(i).offsetY = tmp(3)
col = col + 1
i = i + 1
Loop
' データ収集結果の出力処理
Application.ScreenUpdating = False
Dim beforeCalculation As XlCalculation
beforeCalculation = Application.Calculation
Application.Calculation = xlCalculationManual
row = 3
For Each file In files
thisWS.Cells(row, 1) = file.Path
thisWS.Cells(row, 2) = file.DateLastModified
Set targetWB = Workbooks.Open(thisWS.Cells(row, 1), ReadOnly:=True)
col = 3
For i = 0 To UBound(scrapingKeys)
thisWS.Cells(row, col + i) = GetDataFromTargetWB(targetWB, scrapingKeys(i).sheetName, scrapingKeys(i).cellTitle, scrapingKeys(i).offsetX, scrapingKeys(i).offsetY)
Next
targetWB.Close
row = row + 1
Next
Application.ScreenUpdating = True
Application.Calculation = beforeCalculation
End Sub
Public Function GetDataFromTargetWB(targetWB As Workbook, sheetName As String, cellTitle As String, offsetX As Long, offsetY As Long) As String
Dim targetWS As Worksheet
Set targetWS = Nothing
On Error Resume Next
Set targetWS = targetWB.Sheets(sheetName)
If targetWS Is Nothing Then
MsgBox "シートの検索に失敗しました"
Else
Dim foundCell As Range
Set foundCell = Nothing
Set foundCell = targetWS.Cells.Find(cellTitle)
If foundCell Is Nothing Then
MsgBox "セルタイトルの検索に失敗しました"
Else
GetDataFromTargetWB = foundCell.Offset(offsetY, offsetX).Value
End If
End If
End Function
'@es2さんの作成されたモジュールをベースに正規表現ではなくワイルドカードしか使えない処理に変更
'https://qiita.com/es2/items/eeb3a02891ff50b6dabc
Public Function GetFilesForAllDirectories(currentFolder As String, fileNamePattern As String) As Variant
Dim filedic As Object
Set filedic = CreateObject("scripting.dictionary")
Call GetFilePath(currentFolder, fileNamePattern, filedic)
GetFilesForAllDirectories = filedic.Keys
End Function
Private Sub GetFilePath(folderPath As String, fileNamePattern As String, ByRef filedic As Object)
Dim fso As Object: Set fso = CreateObject("scripting.Filesystemobject")
Dim subfolder As Object
For Each subfolder In fso.GetFolder(folderPath).SubFolders
Call GetFilePath(subfolder.Path, fileNamePattern, filedic)
Next
Dim file 'as Fileとしたいですが for eachで帰ってくる要素はVariant限定なのでas Fileはデバッグ以外で使用できません
For Each file In fso.GetFolder(folderPath).files
If LCase(file.name) Like LCase(fileNamePattern) Then
filedic.add file, 0
End If
Next
End Sub
運用テスト
処理時間の問題
実運用環境で実行してみたところ、あまりにも処理が完了するまでに時間がかかったため、改善を試みた。
@zarukishiさんから以下のコメントをもらった。
FSOでネットワークフォルダ検索すると遅いのは
たぶん、宿命です。m(_ _;)m
ただ、FSOを毎回CreateObjectするのはよろしくないです。
（ただでさえ再帰呼び出しのおかげでコールスタックがすごく多いのに、FSOのおかげで自動変数の記憶量がすごいことになりそう）
FSOは外でCreateObjectして、参照渡し（引数の前のByRefは省略可能なので、意識しなくても参照渡し）したほうがよいです。
また、ファイル取得とファイルからのデータ取得を分離し、一回の操作でなかなか処理が終わらないストレスを少し軽減することにした。
セル検索の問題
セルを部分一致で検索しており、期待通りの動作になっていなかった。
FindメソッドをLookAt:=xlWholeで呼び出す必要があった。
ファイルを開くときにメッセージダイアログが表示される問題
ファイルを開くたびに警告メッセージやデータの更新の有無を聞かれ、OKボタンを押下する手間が発生する。
@joojiさんの記事を参考に、「Excelを静かに開く」対応を実施。
~$ファイルも取得してしまう問題
フォルダ内に、~$ファイル（一時ファイル）が存在していると、そのファイルも取得してしまった。
ファイル名のパターンマッチングで、「~$*.xlsx」を除外する。
ソースコード Ver4.00
' 本プログラムは、Microsoft Scripting Runtimeを有効にして使用する
' フォルダパスと検索するファイル名（ワイルドカード使用可）を定義
Const SEARCH_FOLDER As String = "C:\Users\"
Const FILE_SEARCH_PATTERN As String = "*_test.xlsx"
' データ収集時の検索のキーとなる情報を格納するための構造体
Private Type ScrapingKey
sheetName As String
cellTitle As String
offsetX As Long
offsetY As Long
End Type
' 処理本体
' Excelファイル内の表構成やデータ収集の処理方法を変える場合、修正が必要
Public Sub CreateSerchFileList()
Dim thisWS As Worksheet
Set thisWS = ThisWorkbook.ActiveSheet
Dim row As Long
Dim files: files = GetFilesForAllDirectories(SEARCH_FOLDER, FILE_SEARCH_PATTERN)
Dim file
' データ収集結果の出力処理
Application.ScreenUpdating = False
Dim beforeCalculation As XlCalculation
beforeCalculation = Application.Calculation
Application.Calculation = xlCalculationManual
row = 3
For Each file In files
thisWS.Cells(row, 1) = file.Path
thisWS.Cells(row, 2) = file.DateLastModified
row = row + 1
Next
Application.ScreenUpdating = True
Application.Calculation = beforeCalculation
End Sub
Public Sub ScrapingExcelFileData()
Dim thisWS As Worksheet
Set thisWS = ThisWorkbook.ActiveSheet
Dim targetWB As Workbook
Dim row As Long
Dim col As Long
Dim i As Long
' データ収集時の検索のキーとなる情報を配列に格納
' キーとなる情報は、"SheetName:CellTitle:OffsetX:OffsetY"で表現されている前提の処理
Dim scrapingKeys() As ScrapingKey
Dim scrapingKeyString As String
Dim tmp As Variant
col = 3
i = 0
Do While (thisWS.Cells(2, col) <> "")
ReDim Preserve scrapingKeys(i)
scrapingKeyString = thisWS.Cells(2, col)
tmp = Split(scrapingKeyString, ":")
scrapingKeys(i).sheetName = tmp(0)
scrapingKeys(i).cellTitle = tmp(1)
scrapingKeys(i).offsetX = tmp(2)
scrapingKeys(i).offsetY = tmp(3)
col = col + 1
i = i + 1
Loop
' データ収集結果の出力処理
Application.ScreenUpdating = False
Dim beforeCalculation As XlCalculation
beforeCalculation = Application.Calculation
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
row = 3
Do While (thisWS.Cells(row, 1) <> "")
Set targetWB = Workbooks.Open(thisWS.Cells(row, 1), ReadOnly:=True, UpdateLinks:=0)
col = 3
For i = 0 To UBound(scrapingKeys)
thisWS.Cells(row, col + i) = GetDataFromTargetWB(targetWB, scrapingKeys(i).sheetName, scrapingKeys(i).cellTitle, scrapingKeys(i).offsetX, scrapingKeys(i).offsetY)
Next
targetWB.Close
row = row + 1
Loop
Application.ScreenUpdating = True
Application.Calculation = beforeCalculation
Application.DisplayAlerts = True
End Sub
Public Function GetDataFromTargetWB(targetWB As Workbook, sheetName As String, cellTitle As String, offsetX As Long, offsetY As Long) As String
Dim targetWS As Worksheet
Set targetWS = Nothing
On Error Resume Next
Set targetWS = targetWB.Sheets(sheetName)
If targetWS Is Nothing Then
MsgBox "シートの検索に失敗しました"
Else
Dim foundCell As Range
Set foundCell = Nothing
Set foundCell = targetWS.Cells.Find(cellTitle, LookAt:=xlWhole)
If foundCell Is Nothing Then
MsgBox "セルタイトルの検索に失敗しました"
Else
GetDataFromTargetWB = foundCell.Offset(offsetY, offsetX).Value
End If
End If
End Function
'@es2さんの作成されたモジュールをベースに正規表現ではなくワイルドカードしか使えない処理に変更
'https://qiita.com/es2/items/eeb3a02891ff50b6dabc
Public Function GetFilesForAllDirectories(currentFolder As String, fileNamePattern As String) As Variant
Dim filedic As Object
Set filedic = CreateObject("scripting.dictionary")
Dim fso As Object
Set fso = CreateObject("scripting.Filesystemobject")
Call GetFilePath(currentFolder, fileNamePattern, filedic, fso)
GetFilesForAllDirectories = filedic.Keys
End Function
Private Sub GetFilePath(folderPath As String, fileNamePattern As String, ByRef filedic As Object, ByRef fso As Object)
Dim subfolder As Object
For Each subfolder In fso.GetFolder(folderPath).SubFolders
Call GetFilePath(subfolder.Path, fileNamePattern, filedic, fso)
Next
Dim file 'as Fileとしたいですが for eachで帰ってくる要素はVariant限定なのでas Fileはデバッグ以外で使用できません
For Each file In fso.GetFolder(folderPath).files
If LCase(file.name) Like LCase(fileNamePattern) Then
filedic.add file, 0
End If
Next
End Sub
参考記事
フォルダからのファイル取得
ワイルドカード
ブックを開く
動的配列
構造体配列
文字列のセパレート
シート指定
セル検索
プロシージャ
変数
エラー
その他