Excel仕様出力サンプル

' プロシージャ名 : prcツール構造情報出力
' 機能概要 : 選択されたExcelツールブックの構造情報を抽出し、現在のブックに出力する
' 留意点 : 対象ツールはファイルダイアログで指定し、出力は本ブックの新規シートに行う

Sub prcツール構造情報出力()
    Dim shtOutput As Worksheet
    Dim shtTarget As Worksheet
    Dim lngRow As Long
    Dim wbTool As Workbook
    Dim strFilePath As String
    Dim fd As FileDialog
    Dim strName As String
    Dim nmDefinedName As Name
    Dim shpObj As Shape
    Dim rngCell As Range
    Dim vbComp As Object
    Dim vbProj As Object

    Application.ScreenUpdating = False

    ' ファイルダイアログでツール選択
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .Title = "構造情報を取得するExcelファイルを選択してください"
        .Filters.Clear
        .Filters.Add "Excelファイル", "*.xls; *.xlsx; *.xlsm"
        .AllowMultiSelect = False
        If .Show <> -1 Then Exit Sub
        strFilePath = .SelectedItems(1)
    End With

    ' ツールブックを開く（読み取り専用）
    Set wbTool = Workbooks.Open(Filename:=strFilePath, ReadOnly:=True)

    ' 出力シート初期化
    On Error Resume Next
    ThisWorkbook.Worksheets("構造情報出力").Delete
    On Error GoTo 0
    Set shtOutput = ThisWorkbook.Worksheets.Add
    shtOutput.Name = "構造情報出力"
    lngRow = 1

    ' --- シート情報 ---
    shtOutput.Cells(lngRow, 1).Value = "■ シート情報"
    lngRow = lngRow + 1
    For Each shtTarget In wbTool.Worksheets
        With shtTarget
            shtOutput.Cells(lngRow, 1).Value = "シート名"
            shtOutput.Cells(lngRow, 2).Value = .Name
            shtOutput.Cells(lngRow, 3).Value = "表示状態"
            Select Case .Visible
                Case xlSheetVisible: shtOutput.Cells(lngRow, 4).Value = "表示"
                Case xlSheetHidden: shtOutput.Cells(lngRow, 4).Value = "非表示"
                Case xlSheetVeryHidden: shtOutput.Cells(lngRow, 4).Value = "VeryHidden"
            End Select
            shtOutput.Cells(lngRow, 5).Value = "UsedRange"
            shtOutput.Cells(lngRow, 6).Value = .UsedRange.Address
            shtOutput.Cells(lngRow, 7).Value = "セル数"
            shtOutput.Cells(lngRow, 8).Value = .UsedRange.Cells.Count
            shtOutput.Cells(lngRow, 9).Value = "行固定"
            shtOutput.Cells(lngRow, 10).Value = .ScrollRow
            shtOutput.Cells(lngRow, 11).Value = "列固定"
            shtOutput.Cells(lngRow, 12).Value = .ScrollColumn
            shtOutput.Cells(lngRow, 13).Value = "保護状態"
            shtOutput.Cells(lngRow, 14).Value = IIf(.ProtectContents, "保護中", "未保護")
            shtOutput.Cells(lngRow, 15).Value = "非表示行数"
            shtOutput.Cells(lngRow, 16).Value = WorksheetFunction.CountIf(.Rows.Hidden, True)
            shtOutput.Cells(lngRow, 17).Value = "非表示列数"
            shtOutput.Cells(lngRow, 18).Value = WorksheetFunction.CountIf(.Columns.Hidden, True)
            lngRow = lngRow + 1
        End With
    Next shtTarget
    lngRow = lngRow + 1

    ' --- 名前定義 ---
    shtOutput.Cells(lngRow, 1).Value = "■ 名前定義"
    lngRow = lngRow + 1
    For Each nmDefinedName In wbTool.Names
        shtOutput.Cells(lngRow, 1).Value = nmDefinedName.Name
        shtOutput.Cells(lngRow, 2).Value = nmDefinedName.RefersTo
        lngRow = lngRow + 1
    Next nmDefinedName
    lngRow = lngRow + 1

    ' --- ボタン・オブジェクト情報 ---
    shtOutput.Cells(lngRow, 1).Value = "■ シート内ボタン・オブジェクト概要"
    lngRow = lngRow + 1
    For Each shtTarget In wbTool.Worksheets
        For Each shpObj In shtTarget.Shapes
            shtOutput.Cells(lngRow, 1).Value = shtTarget.Name
            shtOutput.Cells(lngRow, 2).Value = shpObj.Name
            shtOutput.Cells(lngRow, 3).Value = shpObj.Type
            On Error Resume Next
            shtOutput.Cells(lngRow, 4).Value = shpObj.OnAction
            On Error GoTo 0
            lngRow = lngRow + 1
        Next shpObj
    Next shtTarget
    lngRow = lngRow + 1

    ' --- 入力規則 ---
    shtOutput.Cells(lngRow, 1).Value = "■ 入力規則情報（シート別）"
    lngRow = lngRow + 1
    For Each shtTarget In wbTool.Worksheets
        shtOutput.Cells(lngRow, 1).Value = "【" & shtTarget.Name & "】"
        lngRow = lngRow + 1
        For Each rngCell In shtTarget.UsedRange
            If Not rngCell.Validation Is Nothing Then
                If rngCell.Validation.Type <> -4160 Then
                    shtOutput.Cells(lngRow, 2).Value = rngCell.Address
                    shtOutput.Cells(lngRow, 3).Value = rngCell.Validation.Formula1
                    lngRow = lngRow + 1
                End If
            End If
        Next rngCell
    Next shtTarget
    lngRow = lngRow + 1

    ' --- 数式情報 ---
    shtOutput.Cells(lngRow, 1).Value = "■ 数式情報（シート別）"
    lngRow = lngRow + 1
    For Each shtTarget In wbTool.Worksheets
        shtOutput.Cells(lngRow, 1).Value = "【" & shtTarget.Name & "】"
        lngRow = lngRow + 1
        For Each rngCell In shtTarget.UsedRange
            If rngCell.HasFormula Then
                shtOutput.Cells(lngRow, 2).Value = rngCell.Address
                shtOutput.Cells(lngRow, 3).Value = rngCell.Formula
                lngRow = lngRow + 1
            End If
        Next rngCell
    Next shtTarget
    lngRow = lngRow + 1

    ' --- モジュール構成（対象外：別ブックVBAへの直接アクセス不可） ---
    shtOutput.Cells(lngRow, 1).Value = "■ モジュール構成（省略）"
    lngRow = lngRow + 1

    wbTool.Close SaveChanges:=False
    MsgBox "構造情報の出力が完了しました。", vbInformation
    Application.ScreenUpdating = True
End Sub