'■定数定義
Private Const C_PROGRESS_UPDATE_INTERVAL As Long = 1000 ' 進捗表示更新間隔
'--------------------------------------------------
'プロシージャの概要:
'処理名:全シート数式解析処理
'概要:ワークブック内の全シートの数式を解析する
'db:データベース接続オブジェクト
'xlApp:エクセルアプリケーションオブジェクト
'wbTarget:対象ワークブック
'戻り値:処理結果(Boolean)
'--------------------------------------------------
Function analyzeAllSheetsFormula(db As DAO.Database, xlApp As Excel.Application, wbTarget As Excel.Workbook) As Boolean
Dim wsSheet As Worksheet
Dim binResult As Boolean
Dim intSheetCount As Integer
Dim intProcessedSheetCount As Integer
Dim lngTotalFormulaCount As Long
Dim lngProcessedFormulaCount As Long
Dim dtmStartTime As Date
Dim dtmEndTime As Date
On Error GoTo ErrorHandler
' 初期化
analyzeAllSheetsFormula = False
intSheetCount = 0
intProcessedSheetCount = 0
lngProcessedFormulaCount = 0
dtmStartTime = Now()
' 事前スキャン：総数式数を取得
lngTotalFormulaCount = getTotalFormulaCount(wbTarget)
If lngTotalFormulaCount = 0 Then
Application.SysCmd acSysCmdSetStatus, "処理対象の数式が見つかりませんでした"
analyzeAllSheetsFormula = True
Exit Function
End If
' ステータス表示
Application.SysCmd acSysCmdSetStatus, _
"数式情報取得開始... 総数式数: " & lngTotalFormulaCount & "件"
' 全シートを処理
For Each wsSheet In wbTarget.Worksheets
intSheetCount = intSheetCount + 1
' 数式データ取得処理
binResult = getFormulaDataHighSpeed(wsSheet.Name, db, wbTarget, lngProcessedFormulaCount, lngTotalFormulaCount)
If binResult Then
intProcessedSheetCount = intProcessedSheetCount + 1
Debug.Print "処理完了: " & wsSheet.Name
Else
Debug.Print "処理エラー: " & wsSheet.Name
End If
Next wsSheet
' 処理完了
dtmEndTime = Now()
Application.SysCmd acSysCmdSetStatus, _
"処理完了: " & lngProcessedFormulaCount & "件の数式を処理しました " & _
"(" & intProcessedSheetCount & "/" & intSheetCount & "シート) " & _
"処理時間: " & Format(dtmEndTime - dtmStartTime, "nn:ss")
Debug.Print "処理結果: " & intProcessedSheetCount & "/" & intSheetCount & " シート完了"
Debug.Print "数式処理数: " & lngProcessedFormulaCount & "/" & lngTotalFormulaCount & " 件完了"
Debug.Print "処理時間: " & Format(dtmEndTime - dtmStartTime, "hh:nn:ss")
analyzeAllSheetsFormula = True
Exit Function
ErrorHandler:
Application.SysCmd acSysCmdSetStatus, "エラーが発生しました: " & Err.Description
analyzeAllSheetsFormula = False
End Function
'--------------------------------------------------
'プロシージャの概要:
'処理名:総数式数取得処理
'概要:ワークブック内の全シートの数式セル総数を事前取得する
'wb:対象ワークブック
'戻り値:総数式数(Long)
'--------------------------------------------------
Function getTotalFormulaCount(wb As Excel.Workbook) As Long
Dim ws As Excel.Worksheet
Dim rngFormulaCells As Excel.Range
Dim lngTotalCount As Long
Dim blnWasProtected As Boolean
Dim blnPasswordProtected As Boolean
On Error GoTo ErrorHandler
' 初期化
lngTotalCount = 0
' ステータス表示
Application.SysCmd acSysCmdSetStatus, "数式セル総数を取得中..."
' 全シートをスキャン
For Each ws In wb.Worksheets
' 保護状態をチェック
blnWasProtected = ws.ProtectContents
blnPasswordProtected = False
' 保護されている場合は一時解除を試行
If blnWasProtected Then
On Error Resume Next
ws.Unprotect "" ' 空パスワードで解除を試行
If ws.ProtectContents Then
' 解除に失敗した場合はパスワード保護あり
blnPasswordProtected = True
' パスワード保護のシートは1件としてカウント
lngTotalCount = lngTotalCount + 1
' 進捗表示
Application.SysCmd acSysCmdSetStatus, "数式セル総数を取得中... " & ws.Name & " (パスワード保護)"
GoTo NextSheet
End If
On Error GoTo ErrorHandler
End If
' 数式セルを取得
On Error Resume Next
Set rngFormulaCells = ws.Cells.SpecialCells(xlCellTypeFormulas)
On Error GoTo ErrorHandler
' 数式セルが存在する場合はカウントを追加
If Not rngFormulaCells Is Nothing Then
lngTotalCount = lngTotalCount + rngFormulaCells.Count
Set rngFormulaCells = Nothing
End If
' 保護を復元
If blnWasProtected And Not blnPasswordProtected Then
ws.Protect ""
End If
' 進捗表示
Application.SysCmd acSysCmdSetStatus, "数式セル総数を取得中... " & ws.Name
NextSheet:
Next ws
getTotalFormulaCount = lngTotalCount
Exit Function
ErrorHandler:
' 保護を復元
If blnWasProtected And Not blnPasswordProtected Then
On Error Resume Next
ws.Protect ""
On Error GoTo 0
End If
getTotalFormulaCount = 0
End Function
'--------------------------------------------------
'プロシージャの概要:
'処理名:数式セル情報高速取得処理
'概要:ワークシートの数式セルを高速で取得しデータベースに一括登録する
'strSheetName:対象シートの名前
'db:データベース接続オブジェクト
'wb:対象ワークブック
'lngProcessedCount:処理済み数式数(参照渡し)
'lngTotalCount:総数式数
'戻り値:処理結果(Boolean)
'--------------------------------------------------
Function getFormulaDataHighSpeed(strSheetName As String, db As DAO.Database, wb As Excel.Workbook, _
ByRef lngProcessedCount As Long, lngTotalCount As Long) As Boolean
Dim ws As Excel.Worksheet
Dim rngFormulaCells As Excel.Range
Dim arrFormulaData As Variant
Dim arrTempData As Variant
Dim arrValues As Variant
Dim arrFormulas As Variant
Dim lngRowCount As Long
Dim lngColCount As Long
Dim intI As Integer
Dim intJ As Integer
Dim intRowIndex As Integer
Dim lngCurrentSheetCount As Long
Dim blnWasProtected As Boolean
Dim blnPasswordProtected As Boolean
On Error GoTo ErrorHandler
' 初期化
getFormulaDataHighSpeed = False
blnWasProtected = False
blnPasswordProtected = False
' 対象シートを取得
Set ws = wb.Worksheets(strSheetName)
' 保護状態をチェック
blnWasProtected = ws.ProtectContents
' 保護されている場合は一時解除を試行
If blnWasProtected Then
On Error Resume Next
ws.Unprotect "" ' 空パスワードで解除を試行
If ws.ProtectContents Then
' 解除に失敗した場合はパスワード保護あり
blnPasswordProtected = True
On Error GoTo ErrorHandler
' パスワード保護ありメッセージを出力
Call insertPasswordProtectedMessage(strSheetName, db, lngProcessedCount, lngTotalCount)
getFormulaDataHighSpeed = True
Exit Function
End If
On Error GoTo ErrorHandler
End If
' 数式セルが存在するかチェック
On Error Resume Next
Set rngFormulaCells = ws.Cells.SpecialCells(xlCellTypeFormulas)
On Error GoTo ErrorHandler
' 数式セルが存在しない場合はスキップ
If rngFormulaCells Is Nothing Then
' 保護を復元
If blnWasProtected And Not blnPasswordProtected Then
ws.Protect ""
End If
getFormulaDataHighSpeed = True
Exit Function
End If
' 現在のシートの数式数を取得
lngCurrentSheetCount = rngFormulaCells.Count
' 数式セルの情報を配列で一括取得
arrValues = rngFormulaCells.Value
arrFormulas = rngFormulaCells.Formula
' 単一セルの場合の配列化処理
If Not IsArray(arrValues) Then
ReDim arrFormulaData(1 To 1, 1 To 3)
arrFormulaData(1, 1) = strSheetName
arrFormulaData(1, 2) = rngFormulaCells.Address(False, False)
arrFormulaData(1, 3) = arrFormulas
Else
' 複数セルの場合の処理
lngRowCount = UBound(arrValues, 1)
lngColCount = UBound(arrValues, 2)
' データ格納用配列を準備
ReDim arrFormulaData(1 To rngFormulaCells.Cells.Count, 1 To 3)
intRowIndex = 1
' 各セルの情報を配列に格納
For intI = 1 To lngRowCount
For intJ = 1 To lngColCount
If arrFormulas(intI, intJ) <> "" Then
arrFormulaData(intRowIndex, 1) = strSheetName
arrFormulaData(intRowIndex, 2) = rngFormulaCells.Cells(intI, intJ).Address(False, False)
arrFormulaData(intRowIndex, 3) = arrFormulas(intI, intJ)
intRowIndex = intRowIndex + 1
End If
Next intJ
Next intI
' 実際に使用した行数が元の配列サイズより少ない場合は新しい配列を作成
If intRowIndex - 1 < UBound(arrFormulaData, 1) Then
Dim arrTempData As Variant
ReDim arrTempData(1 To intRowIndex - 1, 1 To 3)
' データをコピー
For intI = 1 To intRowIndex - 1
arrTempData(intI, 1) = arrFormulaData(intI, 1)
arrTempData(intI, 2) = arrFormulaData(intI, 2)
arrTempData(intI, 3) = arrFormulaData(intI, 3)
Next intI
' 配列を置き換え
arrFormulaData = arrTempData
End If
End If
' データベースへの一括挿入処理
If UBound(arrFormulaData, 1) > 0 Then
Call insertFormulaDataBatch(arrFormulaData, db, lngProcessedCount, lngTotalCount)
End If
' 保護を復元
If blnWasProtected And Not blnPasswordProtected Then
ws.Protect ""
End If
getFormulaDataHighSpeed = True
Exit Function
ErrorHandler:
' 保護を復元
If blnWasProtected And Not blnPasswordProtected Then
On Error Resume Next
ws.Protect ""
On Error GoTo 0
End If
getFormulaDataHighSpeed = False
End Function
'--------------------------------------------------
'プロシージャの概要:
'処理名:数式データ一括挿入処理
'概要:配列に格納された数式データを1件ずつINSERTで挿入する
'arrData:挿入するデータの配列
'db:データベース接続オブジェクト
'lngProcessedCount:処理済み数式数(参照渡し)
'lngTotalCount:総数式数
'--------------------------------------------------
Sub insertFormulaDataBatch(arrData As Variant, db As DAO.Database, _
ByRef lngProcessedCount As Long, lngTotalCount As Long)
Dim strSQL As String
Dim intI As Integer
Dim lngLastUpdateCount As Long
Dim dblProgress As Double
Dim intProgressPercent As Integer
On Error GoTo ErrorHandler
' 初期化
lngLastUpdateCount = lngProcessedCount
' トランザクション開始
DBEngine.Workspaces(0).BeginTrans
' 1件ずつINSERT処理
For intI = 1 To UBound(arrData, 1)
' INSERT文を作成
strSQL = "INSERT INTO [数式テーブル] ([シート名], [セル番地], [数式]) VALUES " & _
"('" & Replace(arrData(intI, 1), "'", "''") & "', " & _
"'" & Replace(arrData(intI, 2), "'", "''") & "', " & _
"'" & Replace(arrData(intI, 3), "'", "''") & "')"
' INSERT実行
db.Execute strSQL
lngProcessedCount = lngProcessedCount + 1
' 進捗表示更新判定
If (lngProcessedCount - lngLastUpdateCount) >= C_PROGRESS_UPDATE_INTERVAL Or _
intI = UBound(arrData, 1) Then
' 進捗率計算
dblProgress = (lngProcessedCount / lngTotalCount) * 100
intProgressPercent = Int(dblProgress)
' ステータス表示更新
Application.SysCmd acSysCmdSetStatus, _
"数式情報取得中... " & lngProcessedCount & "/" & lngTotalCount & _
"件処理中 (" & intProgressPercent & "%)"
lngLastUpdateCount = lngProcessedCount
End If
Next intI
' トランザクション確定
DBEngine.Workspaces(0).CommitTrans
Exit Sub
ErrorHandler:
' エラー時はロールバック
DBEngine.Workspaces(0).Rollback
Err.Raise Err.Number, Err.Source, Err.Description
End Sub
'--------------------------------------------------
'プロシージャの概要:
'処理名:パスワード保護メッセージ出力処理
'概要:パスワード保護により解析できないシートの情報を出力する
'strSheetName:対象シートの名前
'db:データベース接続オブジェクト
'lngProcessedCount:処理済み数式数(参照渡し)
'lngTotalCount:総数式数
'--------------------------------------------------
Sub insertPasswordProtectedMessage(strSheetName As String, db As DAO.Database, _
ByRef lngProcessedCount As Long, lngTotalCount As Long)
Dim strSQL As String
Dim dblProgress As Double
Dim intProgressPercent As Integer
On Error GoTo ErrorHandler
' パスワード保護メッセージを挿入
strSQL = "INSERT INTO [数式テーブル] ([シート名], [セル番地], [数式]) VALUES " & _
"('" & Replace(strSheetName, "'", "''") & "', " & _
"'パスワード保護', " & _
"'パスワード保護により情報取得不可')"
db.Execute strSQL
' カウンタを1増加
lngProcessedCount = lngProcessedCount + 1
' 進捗表示更新
dblProgress = (lngProcessedCount / lngTotalCount) * 100
intProgressPercent = Int(dblProgress)
Application.SysCmd acSysCmdSetStatus, _
"数式情報取得中... " & lngProcessedCount & "/" & lngTotalCount & _
"件処理中 (" & intProgressPercent & "%) - " & strSheetName & " はパスワード保護"
Exit Sub
ErrorHandler:
' エラーが発生してもスキップして続行
End Sub
Excel