Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 8.1 Pro : Excel 2010)
マクロに記述されているブック名をVBAで調べる
投稿日時: 19/04/16 16:37:20
投稿者: @ふぁんふぁん

現在、ファイルサーバーにExcle2010のブックが多数保存されて、ほとんどのブックの拡張子が「.xls」です。
特定のファイル(ブック)をマクロでOPENし参照しているブックを調査したいのですが、いちいち全ブックを開いてマクロを確認するにはブック数が多いのと、チェック漏れがあっては困るのでExcelでサーバーの特定フォルダのファイル(ブック)一覧をマクロで作成し、下記のチェックをしたいと思っています。
 
   イ)一覧のブックにマクロがあるか
  ロ)マクロ内に特定のブックをOPENしている記述があるか
   (複数のモジュールやUSERFORMを使用しているブックもあります)
 
フォルダー内のファイル一覧をExcelのシートに展開するところまではマクロで出来るのですが、イ)ロ)については知識不足です。
 
ご存知の方がおられましたら教えて下さい。
 

回答
投稿日時: 19/04/16 16:53:16
投稿者: WinArrow
投稿者のウェブサイトに移動

>フォルダー内のファイル一覧をExcelのシートに展開するところまではマクロで出来るのですが
 
そのマクロを添削したほうが早い=あなたも理解しやすい=
と思うので、コードを掲示できますか?

投稿日時: 19/04/16 17:17:14
投稿者: @ふぁんふぁん

失礼しました。
 
一覧表作成はこのようなコードです
Option Explicit
    Dim ブック名 As String
    Dim wsパス As Worksheet
    Dim 一覧表パス As String
    Dim ファイル名 As String
    Dim 明細Row As Long
Sub ファイル取り込み処理()
'フォルダパス名設定
    Set wsパス = ThisWorkbook.Worksheets("PATH") 
' パスシートの一覧エリアをクリアする
    wsパス.Range("B7:F10000").ClearContents
'ファイル名と更新日時を表示する
    一覧表パス = wsパス.Range("B3")
    ファイル名 = Dir(一覧表パス & "*.xls")
    明細Row = 6
    Do While ファイル名 <> ""
       明細Row = 明細Row + 1
       wsパス.Range("B" & 明細Row) = ファイル名
       wsパス.Range("C" & 明細Row) = Format(FileDateTime(一覧表パス & ファイル名), "yyyy/m/d")
       wsパス.Range("D" & 明細Row) = Format(FileDateTime(一覧表パス & ファイル名), "hh:mm")
       ファイル名 = Dir()
    Loop
End Sub
 
宜しくお願いいたします。

回答
投稿日時: 19/04/16 18:07:53
投稿者: WinArrow
投稿者のウェブサイトに移動

VBAでVBAコード操作するようなコードは、ウイルス助長する可能性があるので
モジュールをExportして、テキスト形式のファイルを検索する方法を提案します。
除く、検索処理(検索は、シートに読み込んでも可能です)
 
対象ブックは開いてあるという前提になっています。
 
Sub ModuleExport()
Dim wbk As Workbook
Dim wkM As Object, ext As String
 
    For Each wbk In Workbooks
        For Each wkM In wbk.VBProject.VBComponents
            If wkM.codemodule.CountOfLines > 0 Then
                Select Case wkM.Type
                    Case 1: ext = ".bas"
                    Case 3: ext = ".frm"
                    Case 2: ext = ".cls"
                    Case 100: ext = ".cls"
                End Select
                wkM.Export Filename:="D:\TEST\" & wbk.Name & "_" & wkM.Name & ext
            End If
        Next
    Next
End Sub

回答
投稿日時: 19/04/16 18:20:49
投稿者: WinArrow
投稿者のウェブサイトに移動

追加レス
  
 (1)コードは、対象ブックは、開いてあるという前提で記述してあるので、
  シートの一覧表から対象ブックを開き、用が済んだら閉じる
 というようにするとよいでしょう。
  一度に全部開くのは得策ではない。
  
 (2)モジュールのコード行を1以上としてありますが、
  例えば、「Option Explicit」だけのモジュールは、スキップするようにした方がよいでしょう。
  結果的に、マクロ無ブックは、Exportされないことになります。

投稿日時: 19/04/17 14:51:39
投稿者: @ふぁんふぁん

WinArrow 様
 
追加レス及び ModuleExport を参考にさせていただいて、指定フォルダにテキスト形式のファイルを出力することにしました。
また、「記述されているブック名を調べる」につきましてはテキストファイルを開き「InStr関数」で有無を確認するようにしたいと思っています。
 
以下は、テキストファイルを出力するまでのVBAコードです。
ちゃんと動作し、指定フォルダにテキストファイルが出力されました。
ありがとうございました。
--------------------------------------------------------------------------------------------
Option Explicit
Sub エクセルブック取り込み処理()
    Dim wsパス As Worksheet
    Dim 一覧表パス As String
    Dim ファイル名 As String
    Dim 対象ブック As String
    Dim wbk As Workbook 'ワークブック
    Dim wkM As Object 'タイプ
    Dim ext As String 'マクロ名
    Dim 明細Row As Long
    Dim 明細End As Long
     
    Set wsパス = ThisWorkbook.Worksheets("PATH")
    Dim 開始時間, 終了時間, 所要時間, 開始time, 終了time, 所要time
    開始time = Time()
    開始時間 = Format(Now(), "HH:mm:ss")
' 一覧エリアとコード表シートをクリアする
    明細End = wsパス.Range("B10000").End(xlUp).Row
    MsgBox 明細End
    If 明細End > 6 Then
       wsパス.Range("B7:C" & 明細End).ClearContents
    End If
'フォルダ内のファイル名を取得し表示する
    一覧表パス = wsパス.Range("B3")
    ファイル名 = Dir(一覧表パス & "*.xls")
    明細Row = 6
    Do While ファイル名 <> ""
       明細Row = 明細Row + 1
       wsパス.Range("B" & 明細Row) = ファイル名
       ファイル名 = Dir()
    Loop
'ファイル名一覧より、ファイルをOPENしVBAコードがあればテキストファイルにして保存する
    明細End = 明細Row
    For 明細Row = 7 To 明細End
       ファイル名 = 一覧表パス & wsパス.Range("B" & 明細Row).Value
       対象ブック = Dir(ファイル名)
       If 対象ブック <> "" Then
          Workbooks.Open Filename:=ファイル名, ReadOnly:=True, UpdateLinks:=3
          For Each wbk In Workbooks
             For Each wkM In wbk.VBProject.VBComponents
                If wkM.codemodule.CountOfLines > 1 Then '1行以上あるVBAコードのみ対象とする
                   Select Case wkM.Type
                      Case 1: ext = "_bas"
                      Case 3: ext = "_frm"
                      Case 2: ext = "_cls"
                      Case 100: ext = "_cls"
                   End Select
                   wkM.Export Filename:="D:\保管\" & wbk.Name & "_" & wkM.Name & ext & ".txt"
                End If
             Next
          Next
          Workbooks(対象ブック).Close SaveChanges:=False
       Else
          MsgBox ファイル名 & " が見つかりません"
       End If
    Next 明細Row
 
    終了time = Time()
    終了時間 = Format(Now(), "HH:mm:ss")
    所要time = 終了time - 開始time
    所要時間 = Format(所要time, "HH:mm:ss")
    MsgBox "エクセルブック取込み処理は正常に終了しました。 " & vbCrLf & _
           "   開始時間 : " & 開始時間 & vbCrLf & _
           "   終了時間 : " & 終了時間 & vbCrLf & _
           "   所要時間 : " & 所要時間
End Sub