'--------------------------------------------------
'プロシージャの概要:
'処理名: exec全数式取込
'概要: 対象ブックの全シートから数式を取得してAccessテーブルに格納
'--------------------------------------------------
Public Sub exec全数式取込()
Dim strTargetPath As String
Dim wb As Workbook
Dim ws As Worksheet
Dim varFormulas As Variant
Dim varValues As Variant
Dim lngRow As Long
Dim lngCol As Long
Dim db As DAO.Database
Dim rsFormulas As DAO.Recordset
Dim lngRecordCount As Long
Dim strSQL As String
'ファイル選択ダイアログ
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "解析対象Excelファイルを選択"
.Filters.Clear
.Filters.Add "Excelファイル", "*.xls;*.xlsx;*.xlsm"
If .Show <> -1 Then
Exit Sub
End If
strTargetPath = .SelectedItems(1)
End With
'Excelの設定を最適化
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
'データベース準備とテーブル初期化
Set db = CurrentDb
strSQL = "DELETE FROM t数式テーブル"
db.Execute strSQL, dbFailOnError
'レコードセット準備
Set rsFormulas = db.OpenRecordset("t数式テーブル", dbOpenDynaset)
'対象ブックを開く
Set wb = Workbooks.Open(strTargetPath, ReadOnly:=True)
'トランザクション開始（高速化）
DBEngine.BeginTrans
'シート数カウント用変数
Dim lngSheetCount As Long
Dim lngCurrentSheet As Long
Dim dblProgress As Double
'総シート数を取得
lngSheetCount = wb.Worksheets.Count
lngCurrentSheet = 0
'全シートをループ
For Each ws In wb.Worksheets
'シートカウンタを増やす
lngCurrentSheet = lngCurrentSheet + 1
'進捗率計算
dblProgress = (lngCurrentSheet / lngSheetCount) * 100
'ステータスバー更新
SysCmd acSysCmdSetStatus, "数式取得中・・・" & ws.Name & " " & _
lngCurrentSheet & "/" & lngSheetCount & _
" (" & Format(dblProgress, "0") & "%)"
DoEvents '強制描画
With ws.UsedRange
'空のシートはスキップ
If .Cells.Count = 1 And .Cells(1, 1).Formula = "" Then
GoTo NextSheet
End If
'========================================
'配列による高速取得処理（ここが最重要）
'========================================
'通常、セル単位でFormulaを取得すると遅いが
'範囲全体のFormulaを配列に一括取得すると激速
varFormulas = .Formula '全セルの数式を2次元配列に一括取得
varValues = .Value '全セルの値も2次元配列に一括取得（比較用）
'単一セルの場合の処理
'（単一セルの場合、配列ではなく単一値が返るため配列化）
If Not IsArray(varFormulas) Then
ReDim varFormulas(1 To 1, 1 To 1)
ReDim varValues(1 To 1, 1 To 1)
varFormulas(1, 1) = .Formula
varValues(1, 1) = .Value
End If
'========================================
'配列内をループして数式を判定・抽出
'========================================
'この時点でExcelとの通信は終了しており
'メモリ上の配列を処理するため高速
For lngRow = 1 To UBound(varFormulas, 1) '行方向のループ
For lngCol = 1 To UBound(varFormulas, 2) '列方向のループ
'数式判定："="で始まる文字列は数式
'（varFormulas配列には数式なら"=SUM(A1:A10)"のような文字列、
' 値なら"100"のような値が格納されている）
If Left$(varFormulas(lngRow, lngCol), 1) = "=" Then
'Accessテーブルにレコード追加
rsFormulas.AddNew
rsFormulas!シート名 = ws.Name
'配列のインデックスから実際のセル番地を算出
rsFormulas!セル番地 = .Cells(lngRow, lngCol).Address(False, False)
rsFormulas!数式 = varFormulas(lngRow, lngCol)
rsFormulas.Update
lngRecordCount = lngRecordCount + 1
End If
Next lngCol
Next lngRow
End With
NextSheet:
Next ws
'トランザクションコミット
DBEngine.CommitTrans
'クリーンアップ
rsFormulas.Close
Set rsFormulas = Nothing
wb.Close SaveChanges:=False
Set wb = Nothing
Set db = Nothing
'Excelの設定を戻す
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
'処理完了メッセージ
MsgBox "数式取込完了" & vbCrLf & _
"取込件数: " & Format(lngRecordCount, "#,##0") & " 件", _
vbInformation
'ステータスバーをクリア
SysCmd acSysCmdClearStatus
End Sub
Excel