全ファイル | nujonoa_blog

【VBA】特定フォルダのファイルとシート一覧表＋ハイパーリンクを作る方法

nujonoa — Fri, 05 Feb 2021 13:45:00 +0000

【VBA】特定フォルダのファイルとシート一覧表＋ハイパーリンクを作る方法
プログラム紹介
プログラムの説明
まとめ

【VBA】特定フォルダのファイルとシート一覧表＋ハイパーリンクを作る方法

フォルダ内のファイル一覧は簡単に取り出すことができますが、
フォルダ内のエクセル「シート」一覧をとりだすのは少しテクニックが要ります。

そこで今回は、特定のフォルダ内のエクセルのシート一覧を読み込むことができる、
プログラムを紹介したと思います。

プログラム紹介

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

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

※ダブルクリックでコピー

Sub JIKKOU()
  
        Call DBMacro("C:\Users\bluei\OneDrive\ドキュメント\blog\fp") '←検索したいフォルダを指定する。
      
End Sub
 
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) = "シートへのリンク"
    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
    
'db関数を使用。
    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"",""リンク"")"
      
        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 '自動計算開始
     
  Application.ScreenUpdating = True
      
End Sub

プログラムの説明

プログラムは、
・ADOを使って、エクセルをDBとみなして、
　各ファイルのシートの情報をとってくる
・その情報と、パスの情報を組み合わせて、ハイパーリンクを作成していく

Cells(Z, 6) = "=HYPERLINK(A" & Z & "&""#""&C" & Z & "&""!A1"",""リンク"")"

プログラムとなっています。

まとめ

フォルダの整理が追い付かなくなってきたら、
ぜひ使ってみていただけたらと思います。

【VBA】ファイルを立ち上げずに、セルの情報を抜き出す方法

nujonoa — Thu, 04 Feb 2021 14:07:43 +0000

【VBA】ファイルを立ち上げずに、エクセルの情報を抜き出す方法
プログラム紹介
プログラムの説明
まとめ

【VBA】ファイルを立ち上げずに、エクセルの情報を抜き出す方法

エクセルで他のシートからセルの情報を持ってこようとすると、
ブックを立ち上げて、情報をコピーして、閉じてを繰り返し行う必要があります。

が、そんなことやっていたら日が暮れてしまいますよね。。

そこで今回は、ファイルを立ち上げずに、下記のように

・特定のフォルダ内の
・全ブックの
・全シートの
・特定のセルの情報
を持ってくる方法を紹介したいと思います。

プログラム紹介

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

※ダブルクリックでコピーできます。

Sub JIKKOU()
 
        Call DBMacro("C:\Users\bluei\OneDrive\ドキュメント\blog\fp") '←検索したいフォルダを指定する。
     
End Sub

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
   
'db関数を使用。
    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"  '任意のセルに変更

 
            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

プログラムの説明

ADOを使って、エクセルをDBとみなして、
各ファイルのシートをすべてとってきています。

'db関数を使用。
    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, "''", "'")

その情報を使って、
・そのブックにリンクを作っていきます。
【＝'パス名[ブック名]シート名'セル名】
例)='C:\Users\bluei\OneDrive\ドキュメント\blog\fp[(201912)簡易FP.xlsx]→'!F6】

他のファイルで↓の表示が出ると、かなり萎えますが、今回の場合は、これを思う存分行うようにしています。

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

まとめ

暗黙知を形式知にしたり、情報の共有を図るために、

・何かしらのフォーマットにある程度のルールにのっとったファイル

を作っていくことがあると思いますが、
残念ながらそれがうまく活用されることが少ないように感じます。

そのハードルを下げるためにも、誰もが使っているエクセルで、
DBを作ることに意味はあると思います。

是非検討してみてください！！

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

nujonoa — Sat, 23 Jan 2021 13:53:11 +0000

【エクセルDB】フォルダ内の全ファイル全シートの情報を書き出す。
プログラム紹介
プログラムの説明
まとめ

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

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

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

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

というプログラムです。

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

プログラム紹介

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

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

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】みたいな外部リンクの数式をじゃんじゃん作っていく。

イメージです。

よくある悪者

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

まとめ

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

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