マクロモジュールの一覧表を作成したい。

質問

先日来、VBAマクロが突然消える症状で困惑しておりましたが、本欄に投稿することで解決しました。
その過程で、既存のExcel Bookにあるマクロの一覧を別のフォルダーに取り出し、一覧にしたいと思いました。
Web検索でその方法を見つけ、MyMacroFolderに一覧とすることが出来ました。しかし、これらは添付ファイルのようにmodule1.bas,module2.bas.....であり、どのようなマクロか分かりません。それでExcel VBAを使ってmodule1,module2,...と開きながら、sub マクロ名で記されている名前を
module1 マクロ名１
module2　マクロ名2
.
.
のように出力したいのですが、どのように記述すればよろしいのでしょうか？

回答No.7

HohoPapa · ベストアンサー

続いて、
>お時間のある時にでもチェックして頂ければ幸いです。
の話。

Module1.bas、Module2.bas、Module3.bas
といった具合に、
１からの連番で、かつ、あらかじめ幾つまであるのかを指定できるのであれば、

Sub SampleB()

　Dim buf As String
　Dim cnt As Long
　Dim PutR As Long
　Dim PutSh As Worksheet
　Dim c As Long

　Const Path As String = "C:\Test\" '*.bas　格納フォルダー

　PutR = 0
　Set PutSh = ThisWorkbook.Sheets(1)　'結果格納シート
　PutSh.Cells.ClearContents　　　　　'結果格納シートクリアー

　For c = 1 To 3　　'moduleの数

　　Open Path & "\" & "Module" & c & ".bas" For Input As #1

　　Do Until EOF(1)
　　　Line Input #1, buf
　　　If (Left(UCase(buf), 3) = "SUB") Or _
　　　　((InStr(UCase(buf), " SUB ") > 0) And _
　　　　(UCase(Left(buf, 3)) <> "END")) Then
　　　　PutR = PutR + 1
　　　　PutSh.Cells(PutR, 1).Value = "Module" & c
　　　　PutSh.Cells(PutR, 2).Value = buf
　　　End If
　　Loop

　　Close #1
　Next c
End Sub

といったコードになります。

一方、
多くの場合
Module1.bas、Module2.bas、Module3.bas
とはせずに、
Mod_Main、Mod_Sub、Mod_Etc
といった具合に、中身を連想できる名前にすることが一般的です。

であれば、フォルダーを指定し、*.basを探し
見つかったものから順番に、対象とするコードにすることとなりましょう。
その場合は

Sub SampleA()

　Dim buf1 As String
　Dim buf2 As String
　Dim cnt As Long
　Dim PutR As Long
　Dim PutSh As Worksheet

　Const Path As String = "C:\Test\" '*.bas　格納フォルダー

　PutR = 0
　Set PutSh = ThisWorkbook.Sheets(1)　'結果格納シート
　PutSh.Cells.ClearContents　　　　　'結果格納シートクリアー

　buf1 = Dir(Path & "*.bas")
　Do While buf1 <> ""

　　Open Path & "\" & buf1 For Input As #1

　　Do Until EOF(1)
　　　Line Input #1, buf2
　　　If (Left(UCase(buf2), 3) = "SUB") Or _
　　　　((InStr(UCase(buf2), " SUB ") > 0) And _
　　　　(UCase(Left(buf2, 3)) <> "END")) Then
　　　　PutR = PutR + 1
　　　　PutSh.Cells(PutR, 1).Value = buf1
　　　　PutSh.Cells(PutR, 2).Value = buf2
　　　End If
　　Loop

　　Close #1
　　buf1 = Dir()

　Loop

End Sub

といったコードになります。

momochan1128さんは、
Module1.bas　をエクセルで開いていますが
これは（エクセルで開くこともできますが）
単なるテキストファイルで、文字コードが必ずANSIですので、
私はベーシックなOPEN処理で開いています。

また、サンプルでは、
Sub 自動記録で作成したものを手直しする()
といった具合に、
サブプロシージャ名に日本語を使っているようですが、
間違いではありませんし、正しく動作しますが、
使わないほうが、「かっこいい」とされます。

https://www.exvba.com/1669/　が参考になりましょう。

で、このスレッドのきっかけは
コード全数が突然消える問題に出会っていることでしたね。

相当昔（１０年近く前かも）
サブプロシージャ名に日本語を使っていると、
コード全数が削除されてします障害があったことを思い出します。

少なくとも私は、他の言語も扱っているからかもしれませんが
本能的に、「変数名やサブプロシージャ名に日本語は使わない」です。

お礼

本当に何から何まで懇切丁寧にお答え頂き感謝申し上げます。
まだ、すべてを確認した訳ではありませんが、これだけ説明して頂ければ十分です。これから一つ一つ確認しながらの作業が楽しみです。
sub 名など日本語入力は使えても使わない方が良いも、よく分かります。今、勉強中のPython等は基本的に日本語は使えないことも多く、私自身英語は苦になりませんので、これを機にそうすることにします。
本当にありがとうございました。

回答No.6

HohoPapa

>strDec = .Lines(1, .CountOfDeclarationLines) & vbCrLf
>この行で
>実行時エラー'-2147024809(80070057)':
>プロシージャーの呼び出し、または引数が不正です。

このエラーが起きる問題は、正直よくわかりません。
当方の環境は、Windows10(64ビット)+Office2013(32ビット)です。
むろん、正常に動作します。

今は事情があって、最新版Officeの64ビット版が手元になく
未確認ですが、Officeが64ビットの場合NGかもしれません。

なお、エラーの行は、改めて確認すると不要な行です。
以下のコードを試してみてください。

Option Explicit

Dim PutR As Long
Dim PutSh As Worksheet

Sub abc()

　Dim i As Integer
　Dim wk As Workbook
　PutR = 0

　Set PutSh = ThisWorkbook.Sheets(1)
　PutSh.Cells.ClearContents
　Set wk = Workbooks.Open(Filename:="C:\Test\GetDir.xlsm", _
　　　　　　　　　　　　　　UpdateLinks:=0)
　For i = 1 To wk.VBProject.VBComponents.Count
　　If wk.VBProject.VBComponents(i).Type = 1 Then '標準モジュールのみを対象
　　　SauceGet wk, wk.VBProject.VBComponents(i).Name
　　End If
　Next
　wk.Close
End Sub

Sub SauceGet(w As Workbook, ModName As String)

'　Dim strDec As String
　Dim strAll As String
　Dim CodeTexts
　Dim i As Long

　With w.VBProject.VBComponents.Item(ModName).CodeModule
'　　strDec = .Lines(1, .CountOfDeclarationLines) & vbCrLf
　　strAll = .Lines(1, .CountOfLines)
　　CodeTexts = Split(strAll, vbCrLf)

　　For i = 0 To UBound(CodeTexts)
　　　If (UCase(Left(CodeTexts(i), 3)) = "SUB") Or _
　　　　((InStr(UCase(CodeTexts(i)), " SUB ") > 0) And _
　　　　(UCase(Left(CodeTexts(i), 3)) <> "END")) Then
　　　　PutR = PutR + 1
　　　　PutSh.Cells(PutR, 1).Value = ModName
　　　　PutSh.Cells(PutR, 2).Value = CodeTexts(i)
　　　End If
　　Next i

　End With

End Sub

回答No.5

HohoPapa

>下記に貼り付けておきますので、お時間のある時にでもチェックして頂ければ幸いです。
これは、

・提示されたマクロを実行する前に
　　モジュールごとにエクスポートして
　　（Module1.basを作成し）
・提示されたマクロで、
　　Module1.basの中身をシートに貼り付けているようです。

>チェックして頂ければ幸いです
チェックするのはヤブサカではありませんが
最終的になにがしたいのかを説明してください。

私の提示したマクロと同じように
モジュール名とSUBの行を一覧にいしたいですか？

お礼

そうです。貴方の提示したマクロと同じように
モジュール名とSUBの行を一覧にいしたいのです。

私の書いたコードはとにかく結果を求めるためのもので、貴方のようなエキスパートから見れば、あきれる程幼稚な書き方であることは私自身でも分かっております。
それで、このコードをもう少しスマートに書くにはのアドバイスをお願いしたかったのです。
貴方のコードが私のBookで成功すれば、それがベストと考えるのでチェックは不要です。

回答No.4

HohoPapa

使い方は以下です。

新たなブックを用意する。

標準モジュールにポストしたコードを貼る

Set wk = Workbooks.Open(FileName:="C:\Users\papa\Desktop\xxx.xlsm", _
このファイル名（フルパス）の部分を
調べたいマクロブックのフルパスに置き換え実行します。

実行結果は
Set PutSh = ThisWorkbook.Sheets(1)
1枚目のシート全数を空にしたうえで
PutSh.Cells.ClearContents

Ａ列にモジュールの名前を
Ｂ列にSUBの行を出力しています。
　　　　PutSh.Cells(PutR, 1).Value = ModName
　　　　PutSh.Cells(PutR, 2).Value = CodeTexts(i)

当方の実行結果を添付します。

なにやらエラーになるとの画像が一時期ポストされたようですが
エラーメッセージと
デバックボタンを押したときに
どの行が黄色に染まるかを教えてください。

お礼

strDec = .Lines(1, .CountOfDeclarationLines) & vbCrLf
この行です。
私の使い方が悪いのかも知れませんが、どのBookで試しても同様の結果です。
実行時エラー'-2147024809(80070057)':
プロシージャーの呼び出し、または引数が不正です。

私の望んでいるのは貴方の実行結果と同じです。

補足

かなり内容が理解できるようになりました。問題解決のヒントになると思うので下記します。

Sub abc()
.
.

Set wk = Workbooks.Open(Filename:="C:\Users\
\Documents\総合通帳.xlsm", _
UpdateLinks:=0)
For i = 1 To wk.VBProject.VBComponents.Count '私のケースでは　iは1 to 419となる。

If wk.VBProject.VBComponents(i).Type = 1 Then '標準モジュールのみを対象

　*Type =1　とは判定されるのは、ループ4回目、それで一度はSub SauceGet(w As Workbook, ModName As String)に飛び、戻ってくる。

Project Explorerの表示で標準モジュールを表示すると
module1
module10
module100
module101
.
.
module11
module110
module111
.
.
module12
module120
module121
module123
.
.
となっており、このmodule123が最初のマクロデータとして記録されている。
その後、エラーとなる。

参考になりませんでしょうか？

回答No.3

HohoPapa

補足します。承知かもしれませんが
ソースコードにアクセスする必要がありますから
セキュリティーセンター、あるいはトラストセンターで
VBAプロジェクトオブジェクトモデルへにアクセスを信頼する必要があります。

お礼

添付ファイルをつけようと思っていたのですが項目が見つからず、焦っています。

回答No.2

HohoPapa

Sub に限るということであれば
後記コードはいかがでしょうか？

Option Explicit

Dim PutR As Long
Dim PutSh As Worksheet

Sub abc()

　Dim i As Integer
　Dim wk As Workbook
　PutR = 0

　Set PutSh = ThisWorkbook.Sheets(1)
　PutSh.Cells.ClearContents
　Set wk = Workbooks.Open(FileName:="C:\Users\papa\Desktop\xxx.xlsm", _
　　　　　　　　　　　　　　UpdateLinks:=0)
　For i = 1 To wk.VBProject.VBComponents.Count
　　If wk.VBProject.VBComponents(i).Type = 1 Then '標準モジュールのみを対象
　　　SauceGet wk, wk.VBProject.VBComponents(i).Name
　　End If
　Next
　wk.Close
End Sub

Sub SauceGet(w As Workbook, ModName As String)

　Dim strDec As String
　Dim strAll As String
　Dim CodeTexts
　Dim i As Long

　With w.VBProject.VBComponents.Item(ModName).CodeModule
　　strDec = .Lines(1, .CountOfDeclarationLines) & vbCrLf
　　strAll = .Lines(1, .CountOfLines)
　　CodeTexts = Split(strAll, vbCrLf)

　　For i = 0 To UBound(CodeTexts)
　　　If (UCase(Left(CodeTexts(i), 3)) = "SUB") Or _
　　　　((InStr(UCase(CodeTexts(i)), " SUB ") > 0) And _
　　　　(UCase(Left(CodeTexts(i), 3)) <> "END")) Then
　　　　PutR = PutR + 1
　　　　PutSh.Cells(PutR, 1).Value = ModName
　　　　PutSh.Cells(PutR, 2).Value = CodeTexts(i)
　　　End If
　　Next i

　End With

End Sub

お礼

回答ありがとうございました。
私が書くコードとは格が違うと感ずるほど、洗練された書き方と思います。実行結果がどのようになるのか具体的に理解できませんが、私の要望に沿うものであると信じて、コードを書き込み実行した結果はいずれも添付のエラーとなってしまいました。
後段で”VBAプロジェクトオブジェクトモデルへにアクセスを信頼する必要があります。”と書かれていますが、それと関係があるのでしょうか？
信頼するに✓は入れましたが。
私がマクロの自動記録を使い、その結果を手直しをしたコード、格好は悪いですが、何とか目的は達することが出来ました。
ただ、エンド判定や細かい点ではまだまだ未完成です。
下記に貼り付けておきますので、お時間のある時にでもチェックして頂ければ幸いです。

Sub 自動記録で作成したものを手直しする()
'Application.ScreenUpdating = False

Dim i As Integer
Dim c As String

ChDir "C:\Users\****\MyMacro" 'folder

i = 1

Do Until i > 370

c = "module" & i & ".bas"

Debug.Print c

Workbooks.OpenText FileName:= _
c, Origin:=xlWindows, _
StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False _
, Space:=False, Other:=False, FieldInfo:=Array(1, 1), _
TrailingMinusNumbers:=True

Range("A2").Select
Selection.Copy
Windows("MACRO_TEST.xlsm").Activate

Cells(i, 1).Select

ActiveSheet.Paste
Cells(i, 2) = c

Windows(c).Activate
ActiveWindow.Close
i = i + 1

Loop

End Sub

回答No.1

bardfish

VBA用のドキュメント自動生成ツールというモノがあります。

Excel/AccessでVisual Basic for Application(VBA)が使えるようになった頃から存在しているのは知っていましたが使ったことはありませんでした。
VisualBasic用のモノは一度使用したことがありましたが、制約が以外と面倒くさかったのと出力される結果に癖があったので結局は頑張って手作業で作っていました。

で、今軽く検索して見たら製品として売られているではないですか！
フリーで使えるモノもありましたので探してみてください。

お礼

VBA用のドキュメント自動生成ツールで検索しましたが、今回の私の問題解決に役立ちそうなものを見つけ出せませんでした。

VBAでファイル１を開く→必要情報を抽出→ファイル１を閉じる→ファイル2を開く・・・の繰り返し　このような操作を考えていました。

もう少し待って、締め切ります。