<スポンサーリンク>

【エクセルDB】フォルダ内の全ファイル全シートのセルの情報を書き出す。

エクセル
2021.01.23
この記事は約10分で読めます。
コピーボタン
記事のタイトルとURLをコピー
スポンサーリンク

【エクセルDB】フォルダ内の全ファイル全シートの情報を書き出す。

<スポンサーリンク>

エクセルは時代遅れ、、、といわれながらも、
社内外のやり取りはエクセルで行われるのが主ですし、
これからもそれがどっと変わることはないでしょう。
※スプレッドシートはありかなと思うのですが…
　結局なんやかんや表計算ソフトは便利です。

そこで、今回はエクセルデータベースをVBAで無理やり作ってみました。

出来ることは、下記画像の通り、
対象のフォルダ内のエクセルシートの
・ファイルのパス
・エクセルのファイル名
・エクセルのシート名
・そのシートへのリンク
・そのシートの対象のセルの値を読み込む。

フォルダ内の全ファイル全シートの情報を抜き出す。

というプログラムです。

フォルダと、セルの値だけ変えてもらえればすぐに使えますので、
ぜひ参考にしてみてください！！！

プログラム紹介

プログラムを動かす前に、

①VBAの編集画面「ツール→参照」で、
Microsoft ActiveX Data Objects 2.8 Library
を追加して下さい。
②フォルダパスを検索したいパスに設定してください。
③「任意のセルに変更」の箇所を思い通りに変更ください。

それが出来たら実行してください。

001
002
003
004
005
006
007
008
009
010
011
012
013
014
015
016
017
018
019
020
021
022
023
024
025
026
027
028
029
030
031
032
033
034
035
036
037
038
039
040
041
042
043
044
045
046
047
048
049
050
051
052
053
054
055
056
057
058
059
060
061
062
063
064
065
066
067
068
069
070
071
072
073
074
075
076
077
078
079
080
081
082
083
084
085
086
087
088
089
090
091
092
093
094
095
096
097
098
099
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
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】みたいな外部リンクの数式をじゃんじゃん作っていく。

イメージです。

よくある悪者

安全ではない可能性のある外部ソースへのリンクが

を逆に存分に使ってやろうという感じになります。
そのまま数式は残してありますが、最後にコピーして値貼り付けをすれば、
このリンクは削除できますので、変に重たいファイルになることを防ぐことも可能です。

まとめ

結構苦労してたどり着いたプログラムなので、
かわいがってやってください。

何か要望などあれば、コメントへどうぞ！

コメント欄

<スポンサーリンク>
タイトルとURLをコピーしました