'==================================================
' テーブル構造定義
'==================================================
' テーブル名: t名前
'
' フィールド構成:
' 1. ID - オートナンバー型（主キー）
' 2. ブック名 - テキスト型(255)
' 3. シート名 - テキスト型(255)
' 4. スコープ - テキスト型(50) ※"ブック" or "シート"
' 5. 名前 - テキスト型(255)
' 6. セル番地 - テキスト型(255)
' 7. 内容 - メモ型
' 8. 備考 - テキスト型(255)
'==================================================
'--------------------------------------------------
'プロシージャの概要:
'処理名:名前定義取得処理
'概要:Excelファイルの全名前定義を取得してAccessテーブルに格納する
'strFilePath:対象Excelファイルのフルパス
'戻り値:Boolean - 処理成功時True、失敗時False
'--------------------------------------------------
Public Function get名前定義(strFilePath As String) As Boolean
Dim dbCurrent As DAO.Database
Dim rsNames As DAO.Recordset
Dim wbTarget As Workbook
Dim wsSheet As Worksheet
Dim nmName As Name
Dim strSQL As String
Dim strBookName As String
Dim strSheetName As String
Dim strScope As String
Dim strNameText As String
Dim strAddress As String
Dim strRefersTo As String
Dim strRemarks As String
Dim blnProtected As Boolean
Dim lngCount As Long
'定数定義
Const C_TABLE_NAME As String = "t名前"
Const C_DEFAULT_PASSWORD As String = ""
Const C_SCOPE_BOOK As String = "ブック"
Const C_SCOPE_SHEET As String = "シート"
Const C_PROTECT_MESSAGE As String = "パスワード保護により取得不可"
On Error GoTo ErrorHandler
'初期化処理
get名前定義 = False
lngCount = 0
'データベース接続
Set dbCurrent = CurrentDb()
'既存データのクリア確認
strSQL = "DELETE FROM " & C_TABLE_NAME & " WHERE ブック名 = '" & _
Replace(Dir(strFilePath), "'", "''") & "'"
dbCurrent.Execute strSQL
'テーブルオープン
Set rsNames = dbCurrent.OpenRecordset(C_TABLE_NAME, dbOpenDynaset)
'Excelファイルオープン
Set wbTarget = Workbooks.Open(strFilePath, ReadOnly:=True, UpdateLinks:=0)
strBookName = wbTarget.Name
'アプリケーション設定
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With
'全シートの表示状態を保存してから表示
Dim dicSheetVisible As Object
Set dicSheetVisible = CreateObject("Scripting.Dictionary")
For Each wsSheet In wbTarget.Worksheets
'シートの表示状態を保存
dicSheetVisible.Add wsSheet.Name, wsSheet.Visible
'VeryHiddenも含めて一時的に表示
If wsSheet.Visible <> xlSheetVisible Then
wsSheet.Visible = xlSheetVisible
End If
Next wsSheet
'名前定義の取得処理
For Each nmName In wbTarget.Names
With rsNames
.AddNew
'ブック名設定
!ブック名 = strBookName
'名前設定
strNameText = nmName.Name
'シート名が含まれる場合は除去
If InStr(strNameText, "!") > 0 Then
strNameText = Mid(strNameText, InStr(strNameText, "!") + 1)
End If
!名前 = strNameText
'スコープ判定とシート名取得
If nmName.Parent.Name = wbTarget.Name Then
'ブックレベルの名前定義
strScope = C_SCOPE_BOOK
strSheetName = ""
Else
'シートレベルの名前定義
strScope = C_SCOPE_SHEET
strSheetName = nmName.Parent.Name
End If
!スコープ = strScope
!シート名 = strSheetName
'参照先（内容）取得
On Error Resume Next
strRefersTo = nmName.RefersTo
If Err.Number <> 0 Then
strRefersTo = "#ERROR!"
Err.Clear
End If
On Error GoTo ErrorHandler
!内容 = strRefersTo
'セル番地取得
strAddress = ""
strRemarks = ""
On Error Resume Next
'参照範囲からアドレス取得を試行
If Left(strRefersTo, 1) = "=" Then
Dim rngRef As Range
Set rngRef = Nothing
'範囲への参照を試行
Set rngRef = nmName.RefersToRange
If Not rngRef Is Nothing Then
'シート保護チェック
If rngRef.Worksheet.ProtectContents Then
'保護解除を試行
rngRef.Worksheet.Unprotect Password:=C_DEFAULT_PASSWORD
'まだ保護されている場合
If rngRef.Worksheet.ProtectContents Then
strRemarks = C_PROTECT_MESSAGE
End If
End If
'アドレス取得（外部参照も含む完全形式）
strAddress = rngRef.Address(External:=True)
'セル結合チェック
If rngRef.MergeCells Then
'結合範囲全体のアドレスを取得
strAddress = rngRef.MergeArea.Address(External:=True)
End If
End If
End If
Err.Clear
On Error GoTo ErrorHandler
!セル番地 = strAddress
!備考 = strRemarks
.Update
lngCount = lngCount + 1
End With
Next nmName
'シートの表示状態を元に戻す
For Each wsSheet In wbTarget.Worksheets
wsSheet.Visible = dicSheetVisible(wsSheet.Name)
Next wsSheet
'正常終了処理
get名前定義 = True
MsgBox "名前定義の取得が完了しました。" & vbCrLf & _
"取得件数: " & lngCount & " 件", vbInformation, "処理完了"
ExitProc:
'クリーンアップ処理
If Not rsNames Is Nothing Then
rsNames.Close
Set rsNames = Nothing
End If
If Not wbTarget Is Nothing Then
wbTarget.Close SaveChanges:=False
Set wbTarget = Nothing
End If
'アプリケーション設定を戻す
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
Set dbCurrent = Nothing
Exit Function
ErrorHandler:
MsgBox "エラーが発生しました。" & vbCrLf & _
"エラー番号: " & Err.Number & vbCrLf & _
"エラー内容: " & Err.Description, vbCritical, "エラー"
Resume ExitProc
End Function
'--------------------------------------------------
'プロシージャの概要:
'処理名:ファイル選択ダイアログ表示処理
'概要:Excelファイルを選択して名前定義取得処理を実行する
'--------------------------------------------------
Public Sub exec名前定義取得()
Dim strFilePath As String
Dim fdDialog As FileDialog
'ファイル選択ダイアログの設定
Set fdDialog = Application.FileDialog(msoFileDialogFilePicker)
With fdDialog
.Title = "名前定義を取得するExcelファイルを選択"
.Filters.Clear
.Filters.Add "Excelファイル", "*.xls; *.xlsx; *.xlsm; *.xlsb"
.AllowMultiSelect = False
'ダイアログ表示
If .Show = -1 Then
strFilePath = .SelectedItems(1)
'名前定義取得処理実行
Call get名前定義(strFilePath)
Else
MsgBox "ファイルが選択されませんでした。", vbInformation, "処理中止"
End If
End With
Set fdDialog = Nothing
End Sub
Excel