【エクセルDB】フォルダ内の全ファイル全シートの情報を書き出す。
エクセルは時代遅れ、、、といわれながらも、
社内外のやり取りはエクセルで行われるのが主ですし、
これからもそれがどっと変わることはないでしょう。
※スプレッドシートはありかなと思うのですが…
結局なんやかんや表計算ソフトは便利です。
そこで、今回はエクセルデータベースをVBAで無理やり作ってみました。
出来ることは、下記画像の通り、
対象のフォルダ内のエクセルシートの
・ファイルのパス
・エクセルのファイル名
・エクセルのシート名
・そのシートへのリンク
・そのシートの対象のセルの値を読み込む。

というプログラムです。
フォルダと、セルの値だけ変えてもらえればすぐに使えますので、
ぜひ参考にしてみてください!!!
プログラム紹介
プログラムを動かす前に、
①VBAの編集画面「ツール→参照」で、
Microsoft ActiveX Data Objects 2.8 Library
を追加して下さい。
②フォルダパスを検索したいパスに設定してください。
③「任意のセルに変更」の箇所を思い通りに変更ください。
それが出来たら実行してください。
Sub DBMacro(Path As String) Application.ScreenUpdating = False ' Application.Calculation = xlCalculationManual '自動計算停止(手動計算) Dim objCn As New ADODB.Connection Dim objRS As ADODB.Recordset Dim sSheet As String Dim i As Long Set fso = CreateObject("Scripting.FileSystemObject") Set cf = fso.GetFolder(Path) Z = 2 Cells(Z, 1) = "ファイルへのパス" Cells(Z, 2) = "ファイル名" Cells(Z, 3) = "シート名" Cells(Z, 4) = "計算用" Cells(Z, 5) = "フォルダパス" Cells(Z, 6) = "シートへのリンク" Cells(Z, 7) = "ここからセルの値⇒⇒" Z = Z + 1 '直下 For Each sFile In cf.Files If sFile = "False" Then Exit Sub End If If sFile.Name Like "*.xls*" Then Else GoTo Continue End If With objCn .Provider = "Microsoft.ACE.OLEDB.12.0" .Properties("Extended Properties") = "Excel 12.0" .Open sFile Set objRS = .OpenSchema(ADODB.adSchemaTables) End With Do Until objRS.EOF sSheet = objRS.Fields("TABLE_NAME").Value If Right(sSheet, 1) = "$" Or Right(sSheet, 2) = "$'" Then If Right(sSheet, 1) = "$" Then sSheet = Left(sSheet, Len(sSheet) - 1) End If If Right(sSheet, 2) = "$'" Then sSheet = Left(sSheet, Len(sSheet) - 2) End If If Left(sSheet, 1) = "'" Then sSheet = Mid(sSheet, 2) End If sSheet = Replace(sSheet, "''", "'") Application.DisplayAlerts = False Cells(Z, 1) = sFile.Path Cells(Z, 2) = sFile.Name Cells(Z, 3) = "'" & Replace(sSheet, "#", ".") Cells(Z, 4) = InStrRev(Cells(Z, 1), "\") Cells(Z, 5) = Left(Cells(Z, 1), Cells(Z, 4)) CELLPASS = "'" & Cells(Z, 5) & "[" & Cells(Z, 2) & "]" & Cells(Z, 3) & "'!" Cells(Z, 6) = "=HYPERLINK(A" & Z & "&""#""&C" & Z & "&""!A1"",""リンク"")" Cells(Z, 7) = "=" & CELLPASS & "F6" '任意のセルに変更 Cells(Z, 8) = "=" & CELLPASS & "Y6" '任意のセルに変更 Cells(Z, 9) = "=" & CELLPASS & "M9" '任意のセルに変更 Cells(Z, 10) = "=" & CELLPASS & "M15" '任意のセルに変更 Cells(Z, 11) = "=" & CELLPASS & "E19" '任意のセルに変更 Cells(Z, 12) = "=" & CELLPASS & "B26" '任意のセルに変更 Cells(Z, 13) = "=" & CELLPASS & "I26" '任意のセルに変更 Cells(Z, 14) = "=" & CELLPASS & "P26" '任意のセルに変更 Cells(Z, 15) = "=" & CELLPASS & "B28" '任意のセルに変更 Cells(Z, 16) = "=" & CELLPASS & "I28" '任意のセルに変更 Cells(Z, 17) = "=" & CELLPASS & "N28" '任意のセルに変更 Cells(Z, 18) = "=" & CELLPASS & "I29" '任意のセルに変更 Cells(Z, 19) = "=" & CELLPASS & "P29" '任意のセルに変更 Cells(Z, 20) = "=" & CELLPASS & "W26" '任意のセルに変更 Cells(Z, 21) = "=" & CELLPASS & "AD26" '任意のセルに変更 Cells(Z, 22) = "=" & CELLPASS & "AK26" '任意のセルに変更 Cells(Z, 23) = "=" & CELLPASS & "W28" '任意のセルに変更 Cells(Z, 24) = "=" & CELLPASS & "AD28" '任意のセルに変更 Cells(Z, 25) = "=" & CELLPASS & "AI28" '任意のセルに変更 Cells(Z, 26) = "=" & CELLPASS & "AD29" '任意のセルに変更 Cells(Z, 27) = "=" & CELLPASS & "AK29" '任意のセルに変更 DoEvents '重すぎるのでフリーズしないように入れる。 'シートをリンクさせないバージョン↓ ' Cells(Z, 8).Value = ExecuteExcel4Macro("'" & Cells(Z, 5) & "[" & Cells(Z, 2) & "]" & Cells(Z, 3) & "'!R26C2") Application.DisplayAlerts = True Z = Z + 1 End If objRS.MoveNext Loop objRS.Close objCn.Close Set objRS = Nothing Set objCn = Nothing Application.StatusBar = Z Continue: Next '子フォルダも同様に、subFolderを実行する。 With CreateObject("Scripting.FileSystemObject") For Each childf In .GetFolder(Path).SubFolders Call DBMacro(childf.Path) Next End With Application.Calculation = xlCalculationAutomatic '自動計算開始 Range(Cells(1, 1), Cells(Z, 30)).Formula = Range(Cells(1, 1), Cells(Z, 30)).Formula Application.ScreenUpdating = True End Sub Sub JIKKOU() Call DBMacro("C:\Users\bluei\OneDrive\ドキュメント\blog\fp") '←検索したいフォルダを指定する。 End Sub
プログラムの説明
長すぎるので、説明は端折りますが、
・ファイルを検索して、
・ファイルがエクセルの場合、その中のシートを全部読み取りハイパーリンクを作成がてら、
・そのシートの特定のセルへ【='C:\Users\bluei\OneDrive\ドキュメント\blog\fp[(201912)簡易FP.xlsx]→'!F6】みたいな外部リンクの数式をじゃんじゃん作っていく。
イメージです。
よくある悪者
を逆に存分に使ってやろうという感じになります。
そのまま数式は残してありますが、最後にコピーして値貼り付けをすれば、
このリンクは削除できますので、変に重たいファイルになることを防ぐことも可能です。
まとめ
結構苦労してたどり着いたプログラムなので、
かわいがってやってください。
何か要望などあれば、コメントへどうぞ!
コメント欄