サンプルプログラム概要
・対象は直下にあるExceファイル(xlsm)のみ。サブフォルダ配下のファイルは対象外
・エクスポートするのは標準モジュールのみ
・ エクスポートする標準モジュールのファイル名は「ファイル名_標準モジュール名.bas」
準備
入力/出力フォルダを設定するセルを決める。ここでは「B3」と「B6」とする
サンプルプログラム
'●MainModule
Option Explicit
Sub execButton_click()
Dim ws As Worksheet
Dim inputFolder As String
Dim outputFolder As String
'初期化処理
Call init(False)
'入力/出力フォルダを取得
Set ws = ActiveSheet
inputFolder = ws.range("B3").Value
outputFolder = ws.range("B6").Value
'標準モジュールのエクスポート
Call exportStandardModule(inputFolder, outputFolder)
'後片付け
Set ws = Nothing
'初期化処理
Call init(True)
End Sub
'初期化処理
'画面描画/イベント/確認メッセージ/自動計算の抑止、抑止解除
Private Function init(status As Boolean)
With Application
.ScreenUpdating = status
.EnableEvents = status
.DisplayAlerts = status
If status Then
.Calculation = xlCalculationAutomatic
Else
.Calculation = xlCalculationManual
End If
End With
End Function
'●exportModule
Option Explicit
'標準モジュールのエクスポート
Public Function exportStandardModule(inputFolder As String, outputFolder As String)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
'標準モジュールのエクスポート
Call execStandardExportModule(inputFolder, outputFolder, fso)
Set fso = Nothing
End Function
'標準モジュールのエクスポート
Private Function execStandardExportModule(inputFolder As String, _
outputFolder As String, _
fso As Object)
Const TARGET_FILE_TYPE As String = "xlsm"
Dim file As Object
Dim folders As Object
Dim ws As Worksheet
Dim wk As Workbook
Dim i As Integer
Dim VBComponents As Object
Set ws = ActiveSheet
'ファイル数分繰り返し
For Each file In fso.getFolder(inputFolder).files
If LCase(fso.GetExtensionName(file.Name)) = TARGET_FILE_TYPE Then
'Excelファイルを開く ※「リンクの更新」はしないで開く
Set wk = Workbooks.Open(Filename:=file.Path, UpdateLinks:=0)
'モジュール数分繰り返し
Set VBComponents = wk.VBProject.VBComponents
For i = 1 To VBComponents.count
'標準モジュールのみを対象
If VBComponents(i).Type = 1 Then
VBComponents(VBComponents(i).Name).Export _
outputFolder & _
"\" & _
fso.GetBaseName(file.Name) & _
"_" & _
VBComponents(i).Name & _
".bas"
End If
Next
'Excelファイルを保存せずに閉じる
wk.Close SaveChanges:=False
End If
Next
'後片付け
Set VBComponents = Nothing
Set ws = Nothing
Set wk = Nothing
End Function