Option Explicit
' Option Base 1 が設定されていても問題なく動作するように調整
' エラー処理用の定数
Private Const C_ERR_FILE_NOT_FOUND As Long = 53
Private Const C_ERR_TOO_MANY_FORMULAS As Long = 1000 ' カスタムエラー番号
Private Const C_MAX_ROWS As Long = 1000000 ' Excel行制限に近い値
'--------------------------------------------------
'プロシージャの概要:
'処理名:getAllFormulas
'概要:選択したExcelブックの全シートから数式を抽出し、一覧シートに出力する
'--------------------------------------------------
Sub getAllFormulas()
Dim wbSource As Workbook
Dim wsFormulaList As Worksheet
Dim strSourceBookPath As String
Dim strSourceBookName As String
Dim lngStartTime As Long
Dim lngElapsedTime As Long
Dim lngTotalSheetCount As Long
Dim lngTotalFormulaCount As Long
On Error GoTo ErrorHandler
' 処理開始時間を記録
lngStartTime = Timer
' ソースブックのパスを取得
strSourceBookPath = getSourceBookPath()
If strSourceBookPath = "" Then
MsgBox "ファイルが選択されませんでした。処理を中止します。", vbInformation, "処理中止"
Exit Sub
End If
' ソースブックのファイル名のみを取得
strSourceBookName = Mid(strSourceBookPath, InStrRev(strSourceBookPath, "\") + 1)
' 前提条件チェック
If Not checkPrerequisites(strSourceBookPath, strSourceBookName) Then
Exit Sub
End If
' 数式一覧シートを初期化
Set wsFormulaList = initializeFormulaSheet()
If wsFormulaList Is Nothing Then
Exit Sub
End If
' アプリケーション設定
setApplicationSettings True
' ソースブックを開く
Set wbSource = openSourceBook(strSourceBookPath)
If wbSource Is Nothing Then
GoTo CleanExit
End If
' 数式を処理
lngTotalFormulaCount = processFormulas(wbSource, wsFormulaList, lngTotalSheetCount, lngStartTime)
' 経過時間の計算
lngElapsedTime = Timer - lngStartTime
' 処理完了メッセージ
MsgBox "数式の抽出が完了しました。" & vbCrLf & _
"合計シート数: " & lngTotalSheetCount & vbCrLf & _
"合計処理数式数: " & lngTotalFormulaCount & vbCrLf & _
"処理時間: " & Format(lngElapsedTime \ 60, "00") & ":" & Format(lngElapsedTime Mod 60, "00"), _
vbInformation, "処理完了"
CleanExit:
' ソースブックを保存せずに閉じる
If Not wbSource Is Nothing Then
wbSource.Close SaveChanges:=False
End If
' 設定を元に戻す
setApplicationSettings False
Exit Sub
ErrorHandler:
' エラーの種類に応じて処理
Select Case Err.Number
Case C_ERR_FILE_NOT_FOUND
MsgBox "指定されたファイルが見つかりません: " & strSourceBookPath, vbCritical, "エラー"
Case Else
MsgBox "エラーが発生しました: " & Err.Number & vbCrLf & Err.Description, vbCritical, "エラー"
End Select
' クリーンアップへ
Resume CleanExit
End Sub
'--------------------------------------------------
'プロシージャの概要:
'処理名:checkPrerequisites
'概要:処理の前提条件をチェックする
'引数リスト
'strSourceBookPath:ソースブックのパス
'strSourceBookName:ソースブックのファイル名
'戻り値:前提条件を満たしていればTrue、そうでなければFalse
'--------------------------------------------------
Private Function checkPrerequisites(ByVal strSourceBookPath As String, ByVal strSourceBookName As String) As Boolean
' パスの存在チェック
If Dir(strSourceBookPath) = "" Then
MsgBox "指定されたパス '" & strSourceBookPath & "' にファイルが存在しません。", vbExclamation, "エラー"
checkPrerequisites = False
Exit Function
End If
' ソースブックが既に開かれているかチェック
If existsWorkbookOpen(strSourceBookName) Then
MsgBox "ブック '" & strSourceBookName & "' は既に開かれています。処理を中止します。", vbExclamation, "エラー"
checkPrerequisites = False
Exit Function
End If
checkPrerequisites = True
End Function
'--------------------------------------------------
'プロシージャの概要:
'処理名:initializeFormulaSheet
'概要:数式一覧シートを初期化する
'戻り値:初期化した数式一覧シート。エラー時はNothing
'--------------------------------------------------
Private Function initializeFormulaSheet() As Worksheet
Dim wsFormulaList As Worksheet
' 数式一覧シートを設定
On Error Resume Next
Set wsFormulaList = ThisWorkbook.Sheets("数式一覧")
On Error GoTo 0
If wsFormulaList Is Nothing Then
MsgBox "このブックに '数式一覧' シートが存在しません。", vbExclamation, "エラー"
Set initializeFormulaSheet = Nothing
Exit Function
End If
' 数式一覧シートをクリア
With wsFormulaList
.Cells.Clear
' タイトル行を設定
With .Range("A1:D1")
.Value = Array("シート名", "セル番地", "数式", "参照先")
.Font.Bold = True
End With
End With
Set initializeFormulaSheet = wsFormulaList
End Function
'--------------------------------------------------
'プロシージャの概要:
'処理名:setApplicationSettings
'概要:アプリケーション設定を切り替える
'引数リスト
'binBeginProcessing:処理開始時はTrue、終了時はFalse
'--------------------------------------------------
Private Sub setApplicationSettings(ByVal binBeginProcessing As Boolean)
With Application
If binBeginProcessing Then
' 処理開始時の設定
.DisplayStatusBar = True
.StatusBar = "処理を開始しています..."
.DisplayAlerts = False
.EnableEvents = False
.ScreenUpdating = False
.Calculation = xlCalculationManual ' 計算を手動に設定
Else
' 処理終了時の設定
.DisplayAlerts = True
.EnableEvents = True
.ScreenUpdating = True
.StatusBar = False
.Calculation = xlCalculationAutomatic ' 計算を自動に戻す
End If
End With
End Sub
'--------------------------------------------------
'プロシージャの概要:
'処理名:openSourceBook
'概要:ソースブックを開く
'引数リスト
'strSourceBookPath:ソースブックのパス
'戻り値:開いたソースブック。エラー時はNothing
'--------------------------------------------------
Private Function openSourceBook(ByVal strSourceBookPath As String) As Workbook
Dim wbSource As Workbook
Application.StatusBar = "ソースブックを開いています..."
On Error Resume Next
Set wbSource = Workbooks.Open(strSourceBookPath, UpdateLinks:=False, ReadOnly:=True, IgnoreReadOnlyRecommended:=True)
If Err.Number <> 0 Then
On Error GoTo 0
MsgBox "ブック '" & strSourceBookPath & "' を開くことができませんでした。" & vbCrLf & _
"エラー: " & Err.Description, vbExclamation, "エラー"
Set openSourceBook = Nothing
Exit Function
End If
On Error GoTo 0
Set openSourceBook = wbSource
End Function
'--------------------------------------------------
'プロシージャの概要:
'処理名:processFormulas
'概要:数式処理のメイン処理
'引数リスト
'wbSource:ソースブック
'wsFormulaList:数式一覧シート
'lngTotalSheetCount:処理したシート数（参照渡し）
'lngStartTime:処理開始時間
'戻り値:処理した数式の総数
'--------------------------------------------------
Private Function processFormulas(ByRef wbSource As Workbook, ByRef wsFormulaList As Worksheet, _
ByRef lngTotalSheetCount As Long, ByVal lngStartTime As Long) As Long
Dim wsSheet As Worksheet
Dim lngSheetCount As Long
Dim lngCurrentSheet As Long
Dim lngFormulaCount As Long
' シート数を取得
lngSheetCount = wbSource.Worksheets.Count
lngTotalSheetCount = lngSheetCount
lngCurrentSheet = 0
lngFormulaCount = 0
' ソースブックの全シートをループ（非表示シートも含む）
For Each wsSheet In wbSource.Worksheets
' 現在のシート番号を更新
lngCurrentSheet = lngCurrentSheet + 1
' 各シート内の数式を処理
lngFormulaCount = lngFormulaCount + processSheetFormulas(wsSheet, wsFormulaList, lngCurrentSheet, lngSheetCount, lngStartTime)
' シート処理完了のステータス表示
Application.StatusBar = wsSheet.Name & "の処理が完了しました (" & lngCurrentSheet & "/" & lngSheetCount & " シート)"
Next wsSheet
processFormulas = lngFormulaCount
End Function
'--------------------------------------------------
'プロシージャの概要:
'処理名:processSheetFormulas
'概要:各シート内の数式処理
'引数リスト
'wsSheet:処理対象シート
'wsFormulaList:数式一覧シート
'lngCurrentSheet:現在のシート番号
'lngSheetCount:シート総数
'lngStartTime:処理開始時間
'戻り値:シート内で処理した数式の数
'--------------------------------------------------
Private Function processSheetFormulas(ByRef wsSheet As Worksheet, ByRef wsFormulaList As Worksheet, _
ByVal lngCurrentSheet As Long, ByVal lngSheetCount As Long, _
ByVal lngStartTime As Long) As Long
Dim rngCell As Range
Dim rngUsedRange As Range
Dim lngTotalCells As Long
Dim lngProcessedCells As Long
Dim arrVarFormulas() As Variant
Dim lngFormulaCount As Long
Dim lngSheetNumber As Long
Dim strReferredCell As String
Dim lngElapsedTime As Long
' 配列の初期化（高速化のため）
lngFormulaCount = 0
lngSheetNumber = 1
ReDim arrVarFormulas(1 To 10000, 1 To 4) ' 初期サイズ（必要に応じて拡張）
With wsSheet
' 使用範囲を取得
Set rngUsedRange = .UsedRange
' 処理するセル数を取得
lngTotalCells = rngUsedRange.Cells.Count
lngProcessedCells = 0
' ステータスバーを更新
Application.StatusBar = .Name & "処理中 (" & lngCurrentSheet & "/" & lngSheetCount & " シート) - 準備中..."
' 行→列の順でチェック
For Each rngCell In rngUsedRange
' 処理済みセル数を更新
lngProcessedCells = lngProcessedCells + 1
' 100セルごとにステータスバーを更新
If lngProcessedCells Mod 100 = 0 Or lngProcessedCells = 1 Then
' 経過時間の計算
lngElapsedTime = Timer - lngStartTime
Application.StatusBar = .Name & "処理中 (" & lngCurrentSheet & "/" & lngSheetCount & " シート) - 現在のシート: " & _
Format(lngProcessedCells / lngTotalCells, "0%") & "完了 (経過時間: " & _
Format(lngElapsedTime \ 60, "00") & ":" & Format(lngElapsedTime Mod 60, "00") & ")"
' DoEventsを呼び出してUIの応答性を維持（最小限）
DoEvents
End If
' セルが数式を含むかチェック
If rngCell.HasFormula Then
' 数式情報を処理
lngFormulaCount = processFormulaCell(rngCell, wsSheet, arrVarFormulas, lngFormulaCount)
' 行数制限チェック（新しいシートが必要か）
If lngFormulaCount >= C_MAX_ROWS Then
' 現在の配列データを出力
outputFormulasToSheet wsFormulaList, arrVarFormulas, lngFormulaCount, lngSheetNumber
' 新しいシート番号を増やす
lngSheetNumber = lngSheetNumber + 1
' 配列をリセット
lngFormulaCount = 0
ReDim arrVarFormulas(1 To 10000, 1 To 4)
' 新しい数式一覧シートを作成
Set wsFormulaList = createNewFormulaSheet(lngSheetNumber)
End If
End If
Next rngCell
End With
' 残りの数式データを出力
If lngFormulaCount > 0 Then
outputFormulasToSheet wsFormulaList, arrVarFormulas, lngFormulaCount, lngSheetNumber
End If
processSheetFormulas = lngFormulaCount
End Function
'--------------------------------------------------
'プロシージャの概要:
'処理名:processFormulaCell
'概要:数式セルの処理
'引数リスト
'rngCell:処理対象セル
'wsSheet:処理対象シート
'arrVarFormulas:数式情報を格納する配列
'lngFormulaCount:現在の数式カウント
'戻り値:更新後の数式カウント
'--------------------------------------------------
Private Function processFormulaCell(ByRef rngCell As Range, ByRef wsSheet As Worksheet, _
ByRef arrVarFormulas() As Variant, ByVal lngFormulaCount As Long) As Long
Dim strReferredCell As String
' 配列が満杯になったら拡張
If lngFormulaCount >= UBound(arrVarFormulas, 1) Then
ReDim Preserve arrVarFormulas(1 To UBound(arrVarFormulas, 1) + 10000, 1 To 4)
End If
' 数式の参照先を取得
strReferredCell = getReferencedCells(rngCell)
' 数式情報を配列に格納
lngFormulaCount = lngFormulaCount + 1
arrVarFormulas(lngFormulaCount, 1) = wsSheet.Name
arrVarFormulas(lngFormulaCount, 2) = rngCell.Address(False, False)
arrVarFormulas(lngFormulaCount, 3) = "'" & rngCell.Formula
arrVarFormulas(lngFormulaCount, 4) = strReferredCell
processFormulaCell = lngFormulaCount
End Function
'--------------------------------------------------
'プロシージャの概要:
'処理名:existsWorkbookOpen
'概要:指定されたブックが開かれているかを確認する
'引数リスト
'strWorkbookName:チェックするブック名
'戻り値:ブックが開かれている場合はTrue、そうでなければFalse
'--------------------------------------------------
Function existsWorkbookOpen(ByVal strWorkbookName As String) As Boolean
Dim wbTarget As Workbook
On Error Resume Next
Set wbTarget = Workbooks(strWorkbookName)
On Error GoTo 0
existsWorkbookOpen = Not wbTarget Is Nothing
End Function
'--------------------------------------------------
'プロシージャの概要:
'処理名:getSourceBookPath
'概要:ファイル選択ダイアログからソースブックのパスを取得する
'戻り値:選択されたファイルのパス、キャンセル時は空文字
'--------------------------------------------------
Function getSourceBookPath() As String
Dim objFd As Office.FileDialog
' ファイル選択ダイアログを表示
Set objFd = Application.FileDialog(msoFileDialogFilePicker)
With objFd
.Title = "数式を抽出するExcelブックを選択してください"
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add "Excelブック", "*.xlsx; *.xlsm; *.xls"
If .Show = True Then
getSourceBookPath = .SelectedItems(1)
Else
getSourceBookPath = ""
End If
End With
End Function
'--------------------------------------------------
'プロシージャの概要:
'処理名:getReferencedCells
'概要:セルの参照先を取得する
'引数リスト
'rngCell:参照先を取得するセル
'戻り値:参照先セルの文字列表現
'--------------------------------------------------
Function getReferencedCells(ByRef rngCell As Range) As String
Dim arrPrecedents As Variant
Dim strResult As String
Dim lngI As Long
On Error Resume Next
' 参照先がある場合
If rngCell.HasPrecedents Then
' 直接の参照セルを取得
Set arrPrecedents = rngCell.DirectPrecedents
' 参照セルが存在する場合
If Not arrPrecedents Is Nothing Then
strResult = ""
' 参照セルの情報を文字列に追加
For lngI = 1 To arrPrecedents.Count
If strResult <> "" Then strResult = strResult & ", "
' 別シートの場合はシート名も追加
If arrPrecedents(lngI).Parent.Name <> rngCell.Parent.Name Then
strResult = strResult & "'" & arrPrecedents(lngI).Parent.Name & "'!"
End If
strResult = strResult & arrPrecedents(lngI).Address(False, False)
Next lngI
Else
strResult = "外部参照または複雑な数式"
End If
Else
strResult = "直接の参照なし"
End If
On Error GoTo 0
getReferencedCells = strResult
End Function
'--------------------------------------------------
'プロシージャの概要:
'処理名:createNewFormulaSheet
'概要:新しい数式一覧シートを作成する
'引数リスト
'lngSheetNumber:シート番号
'戻り値:作成したワークシート
'--------------------------------------------------
Function createNewFormulaSheet(ByVal lngSheetNumber As Long) As Worksheet
Dim wsNewSheet As Worksheet
Dim strSheetName As String
' シート名を生成
strSheetName = "数式一覧" & lngSheetNumber
' 既存のシートをチェック
On Error Resume Next
Set wsNewSheet = ThisWorkbook.Sheets(strSheetName)
' シートが存在しない場合は新規作成
If wsNewSheet Is Nothing Then
Set wsNewSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
wsNewSheet.Name = strSheetName
Else
' シートが存在する場合はクリア
wsNewSheet.Cells.Clear
End If
On Error GoTo 0
' タイトル行を設定
With wsNewSheet.Range("A1:D1")
.Value = Array("シート名", "セル番地", "数式", "参照先")
.Font.Bold = True
End With
Set createNewFormulaSheet = wsNewSheet
End Function
'--------------------------------------------------
'プロシージャの概要:
'処理名:outputFormulasToSheet
'概要:数式データを指定されたシートに出力する
'引数リスト
'wsTarget:出力先シート
'arrVarData:出力データ配列
'lngCount:データ数
'lngSheetNum:シート番号
'--------------------------------------------------
Sub outputFormulasToSheet(ByRef wsTarget As Worksheet, ByRef arrVarData() As Variant, _
ByVal lngCount As Long, ByVal lngSheetNum As Long)
Dim rngOutput As Range
Dim lngI As Long
Dim arrVarOutput() As Variant
' 出力データを配列に整形（明示的にインデックスを1から開始）
ReDim arrVarOutput(1 To lngCount, 1 To 4)
For lngI = 1 To lngCount
arrVarOutput(lngI, 1) = arrVarData(lngI, 1)
arrVarOutput(lngI, 2) = arrVarData(lngI, 2)
arrVarOutput(lngI, 3) = arrVarData(lngI, 3)
arrVarOutput(lngI, 4) = arrVarData(lngI, 4)
Next lngI
' 出力範囲を設定
Set rngOutput = wsTarget.Range("A2").Resize(lngCount, 4)
' 一括で出力
rngOutput.Value = arrVarOutput
' 列幅を自動調整
wsTarget.Columns("A:D").AutoFit
' 書式設定
With wsTarget
.Columns("A:D").HorizontalAlignment = xlLeft
.Rows("1:1").Font.Bold = True
End With
End Sub
Excel
コメント