テストエビンス作成ツール(エクセルで前後比較）

システムの改修時にエクセルブックが
前後で同一のものか、比較するケースがあります。

そういった場合に下記のコードを参考にすると良いでしょう
１つのモジュールでもよいですが、
モジュールは分けておくと管理がしやすいはずです。

Option Explicit
'==========================================================
' モジュール名：mod_UI_RunCompare
' 機能概要　　：基準／比較フォルダ内の同名Excelブックを全シート比較し結果を出力
'==========================================================

'==== モジュール変数（DiffUIオプション列から読み取る）====
Private dbl_許容誤差 As Double
Private bool_大文字小文字区別 As Boolean
Private bool_TRIM比較 As Boolean
Private str_拡張子パターン As String
Private bool_日付同値扱い As Boolean
Private bool_書式差分検出 As Boolean
Private bool_シート名で比較 As Boolean

'----------------------------------------------------------
' 比較実行
' 機能概要 : DiffUI上の比較実行ボタン押下時に全比較処理を実行する
' 引数　　: なし
' 戻り値　: なし
' YYYY/MM/DD 名前
'----------------------------------------------------------
Public Sub run_DiffFolders_Click()
    On Error GoTo ERR_HANDLER
    Dim ws_UI As Worksheet: Set ws_UI = Worksheets("DiffUI")

    ' ユーザー設定を読み込む
    call_読込_ユーザー設定 ws_UI

    ' フォルダパスを取得する
    Dim str_基準Dir As String: str_基準Dir = Trim$(ws_UI.Range("B2").Value)
    Dim str_比較Dir As String: str_比較Dir = Trim$(ws_UI.Range("B3").Value)
    ws_UI.Range("A6:E" & Rows.Count).ClearContents

    ' フォルダパスをチェックする
    If Len(str_基準Dir) = 0 Or Len(str_比較Dir) = 0 Then
        ws_UI.Range("A6").Value = "Target1/Target2 のフォルダパスを指定してください。"
        Exit Sub
    End If

    ' 対象ファイル一覧を取得する
    Dim col_ファイル一覧 As Collection
    Set col_ファイル一覧 = get_対象ファイル一覧(str_基準Dir, str_拡張子パターン)
    If col_ファイル一覧 Is Nothing Or col_ファイル一覧.Count = 0 Then
        ws_UI.Range("A6").Value = "基準フォルダに対象ブックが見つかりません。"
        Exit Sub
    End If

    ' 比較処理を開始する
    Dim lng_出力行 As Long: lng_出力行 = 6
    Dim lng_差分数 As Long
    Dim var_ファイル名 As Variant

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    For Each var_ファイル名 In col_ファイル一覧
        ' ファイルパスを構築する
        Dim str_ファイル名 As String: str_ファイル名 = CStr(var_ファイル名)
        Dim str_基準パス As String: str_基準パス = str_基準Dir & "\" & str_ファイル名
        Dim str_比較パス As String: str_比較パス = str_比較Dir & "\" & str_ファイル名

        ' 比較ファイルの存在をチェックする
        If Dir(str_比較パス) = "" Then
            ws_UI.Cells(lng_出力行, 1).Value = "＜基準＞ " & str_ファイル名
            ws_UI.Cells(lng_出力行, 5).Value = "比較側に同名ファイルなし"
            lng_出力行 = lng_出力行 + 1
            GoTo NEXT_FILE
        End If

        ' 一時ファイルを作成する
        Dim str_比較一時 As String
        str_比較一時 = get_比較側一時コピーパス(str_比較パス)

        ' ブックを開く
        Dim wb_基準 As Workbook, wb_比較 As Workbook
        Set wb_基準 = Workbooks.Open(str_基準パス, ReadOnly:=True)
        Set wb_比較 = Workbooks.Open(str_比較一時, ReadOnly:=True)

        ' 差分を取得する
        Dim col_差分 As Collection
        Set col_差分 = get_全シート差分(wb_基準, wb_比較)

        ' 結果を出力する
        If col_差分.Count = 0 Then
            ws_UI.Cells(lng_出力行, 1).Value = "＜基準⇔比較＞ " & str_ファイル名
            ws_UI.Cells(lng_出力行, 5).Value = "差分なし"
            lng_出力行 = lng_出力行 + 1
        Else
            Dim var_行 As Variant
            For Each var_行 In col_差分
                ws_UI.Cells(lng_出力行, 1).Value = var_行(0)
                ws_UI.Cells(lng_出力行, 2).Value = var_行(1)
                ws_UI.Cells(lng_出力行, 3).Value = var_行(2)
                ws_UI.Cells(lng_出力行, 4).Value = var_行(3)
                ws_UI.Cells(lng_出力行, 5).Value = var_行(4)
                lng_出力行 = lng_出力行 + 1
                lng_差分数 = lng_差分数 + 1
            Next var_行
        End If

        ' ブックを閉じる
        wb_基準.Close False
        wb_比較.Close False
        call_削除_一時ファイル安全 (str_比較一時)
NEXT_FILE:
    Next var_ファイル名

    ' 処理を完了する
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "比較が完了しました。差分：" & lng_差分数 & " 件", vbInformation
    Exit Sub

ERR_HANDLER:
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    ws_UI.Range("A6").Value = "エラー: " & Err.Number & " / " & Err.Description
End Sub


'----------------------------------------------------------
' call_読込_ユーザー設定
' 機能概要 : DiffUIシートのオプション設定列から変数を読み込む
' 引数　　: ws_UI（Worksheet） … DiffUIシート
' 戻り値　: なし
' YYYY/MM/DD 名前
'----------------------------------------------------------
Private Sub call_読込_ユーザー設定(ByVal ws_UI As Worksheet)
    ' ヘッダー行と値行を取得する
    Dim rng_ヘッダ As Range, rng_値 As Range
    Set rng_ヘッダ = ws_UI.Rows(1)
    Set rng_値 = ws_UI.Rows(2)

    ' オプション列を順次処理する
    Dim lng_列 As Long
    For lng_列 = 7 To ws_UI.Cells(1, ws_UI.Columns.Count).End(xlToLeft).Column
        Dim str_項目 As String
        str_項目 = LCase$(Trim$(CStr(rng_ヘッダ.Cells(1, lng_列).Value)))
        ' 項目名に応じて変数を設定する
        Select Case str_項目
            Case "許容誤差": dbl_許容誤差 = Val(rng_値.Cells(1, lng_列).Value)
            Case "大文字小文字区別": bool_大文字小文字区別 = CBool(is_真偽(rng_値.Cells(1, lng_列).Value))
            Case "trim比較": bool_TRIM比較 = CBool(is_真偽(rng_値.Cells(1, lng_列).Value))
            Case "拡張子パターン": str_拡張子パターン = CStr(rng_値.Cells(1, lng_列).Value)
            Case "日付同値扱い": bool_日付同値扱い = CBool(is_真偽(rng_値.Cells(1, lng_列).Value))
            Case "書式差分検出": bool_書式差分検出 = CBool(is_真偽(rng_値.Cells(1, lng_列).Value))
            Case "シート名で比較": bool_シート名で比較 = CBool(is_真偽(rng_値.Cells(1, lng_列).Value))
        End Select
    Next lng_列

    ' デフォルト値を設定する
    If dbl_許容誤差 <= 0 Then dbl_許容誤差 = 0.000001
    If Len(str_拡張子パターン) = 0 Then str_拡張子パターン = "*.xlsx;*.xlsm"
End Sub


'----------------------------------------------------------
' is_真偽
' 機能概要 : TRUE/FALSEを文字列・数値から評価して返す
' 引数　　: var_値（Variant）
' 戻り値　: Boolean
' YYYY/MM/DD 名前
'----------------------------------------------------------
Private Function is_真偽(ByVal var_値 As Variant) As Boolean
    Dim str_値 As String: str_値 = LCase$(Trim$(CStr(var_値)))
    is_真偽 = (str_値 = "true" Or str_値 = "t" Or str_値 = "1" Or str_値 = "yes" Or str_値 = "y" Or str_値 = "on")
End Function


'----------------------------------------------------------
' get_対象ファイル一覧
' 機能概要 : 指定フォルダ内で拡張子一致するファイル名リストを返す
' 引数　　: str_フォルダ（String） … 対象フォルダパス
'             str_拡張（String）　 … "*.xlsx;*.xlsm" のような形式
' 戻り値　: Collection（ファイル名一覧）
' YYYY/MM/DD 名前
'----------------------------------------------------------
Private Function get_対象ファイル一覧(ByVal str_フォルダ As String, ByVal str_拡張 As String) As Collection
    ' 結果格納用コレクションを作成する
    Dim col_結果 As New Collection
    Dim arr_拡張() As String, lng_i As Long
    arr_拡張 = Split(str_拡張, ";")

    ' 各拡張子パターンでファイルを検索する
    Dim str_ファイル As String
    For lng_i = LBound(arr_拡張) To UBound(arr_拡張)
        str_ファイル = Dir(str_フォルダ & "\" & Trim$(arr_拡張(lng_i)))
        Do While str_ファイル <> ""
            ' 一時ファイルを除外する
            If Left$(str_ファイル, 2) <> "~$" Then col_結果.Add str_ファイル
            str_ファイル = Dir()
        Loop
    Next lng_i
    Set get_対象ファイル一覧 = col_結果
End Function


'----------------------------------------------------------
' get_比較側一時コピーパス
' 機能概要 : 同名ブックが開けない問題を回避するため、一時コピーを作成
' 引数　　: str_元（String） … コピー元ファイルパス
' 戻り値　: String（一時コピー先パス／失敗時は元パス）
' YYYY/MM/DD 名前
'----------------------------------------------------------
Private Function get_比較側一時コピーパス(ByVal str_元 As String) As String
    On Error GoTo ERR_HANDLER
    ' ファイル名と拡張子を分離する
    Dim str_ファイル名 As String, str_拡張 As String, str_一時 As String
    str_ファイル名 = Mid$(str_元, InStrRev(str_元, "\") + 1)
    str_拡張 = Mid$(str_ファイル名, InStrRev(str_ファイル名, "."))
    ' 一時ファイル名を生成する
    str_一時 = Environ$("TEMP") & "\" & Left$(str_ファイル名, Len(str_ファイル名) - Len(str_拡張)) & "_tmp" & str_拡張
    ' ファイルをコピーする
    FileCopy str_元, str_一時
    get_比較側一時コピーパス = str_一時
    Exit Function
ERR_HANDLER:
    get_比較側一時コピーパス = str_元
End Function


'----------------------------------------------------------
' call_削除_一時ファイル安全
' 機能概要 : TEMPフォルダに存在する一時ファイルを安全に削除
' 引数　　: str_パス（String）
' 戻り値　: なし
' YYYY/MM/DD 名前
'----------------------------------------------------------
Private Sub call_削除_一時ファイル安全(ByVal str_パス As String)
    On Error Resume Next
    If InStr(1, str_パス, Environ$("TEMP"), vbTextCompare) > 0 Then
        If Dir(str_パス) <> "" Then Kill str_パス
    End If
    On Error GoTo 0
End Sub


'----------------------------------------------------------
' get_全シート差分
' 機能概要 : 2ブック内の全シートを比較して差分結果を返す
' 引数　　: wb_基準 / wb_比較（Workbook）
' 戻り値　: Collection（差分情報）
' YYYY/MM/DD 名前
'----------------------------------------------------------
Private Function get_全シート差分(ByVal wb_基準 As Workbook, ByVal wb_比較 As Workbook) As Collection
    ' 差分結果を格納するコレクションを作成する
    Dim col_結果 As New Collection
    Dim ws_基準 As Worksheet, ws_比較 As Worksheet

    If bool_シート名で比較 Then
        ' 基準ブックの各シートを処理する
        For Each ws_基準 In wb_基準.Worksheets
            On Error Resume Next
            Set ws_比較 = wb_比較.Worksheets(ws_基準.name)
            On Error GoTo 0

            If ws_比較 Is Nothing Then
                ' 比較側に同名シートがない場合
                col_結果.Add Array("＜基準＞", ws_基準.name, "", "", "シート過不足：比較側に存在しません")
            Else
                ' 同名シートを比較する
                call_追加_シート比較 col_結果, ws_基準, ws_比較
            End If
            Set ws_比較 = Nothing
        Next ws_基準

        ' 比較ブックの各シートを処理する
        For Each ws_比較 In wb_比較.Worksheets
            If Not is_シート存在(wb_基準, ws_比較.name) Then
                col_結果.Add Array("＜比較＞", ws_比較.name, "", "", "シート過不足：基準側に存在しません")
            End If
        Next ws_比較
    Else
        ' シート順序で比較する
        Dim lng_i As Long, lng_最大 As Long
        lng_最大 = Application.Min(wb_基準.Worksheets.Count, wb_比較.Worksheets.Count)
        For lng_i = 1 To lng_最大
            call_追加_シート比較 col_結果, wb_基準.Worksheets(lng_i), wb_比較.Worksheets(lng_i)
        Next lng_i
    End If

    Set get_全シート差分 = col_結果
End Function


'----------------------------------------------------------
' call_追加_シート比較
' 機能概要 : シート単位で全セルを比較し、差分をコレクションに追加
' 引数　　: col_出力（Collection） … 差分格納先
'             ws_基準 / ws_比較（Worksheet）
' 戻り値　: なし
' YYYY/MM/DD 名前
'----------------------------------------------------------
Private Sub call_追加_シート比較(ByRef col_出力 As Collection, ByVal ws_基準 As Worksheet, ByVal ws_比較 As Worksheet)
    ' 比較範囲を決定する
    Dim lng_最終行 As Long, lng_最終列 As Long
    lng_最終行 = Application.Max(ws_基準.UsedRange.Rows.Count, ws_比較.UsedRange.Rows.Count)
    lng_最終列 = Application.Max(ws_基準.UsedRange.Columns.Count, ws_比較.UsedRange.Columns.Count)

    ' 全セルを順次比較する
    Dim lng_行 As Long, lng_列 As Long
    For lng_行 = 1 To lng_最終行
        For lng_列 = 1 To lng_最終列
            ' セルの値を取得する
            Dim var_左値 As Variant, var_右値 As Variant
            var_左値 = ws_基準.Cells(lng_行, lng_列).Value
            var_右値 = ws_比較.Cells(lng_行, lng_列).Value

            ' 値が異なる場合は差分として記録する
            If Not is_値等しい(var_左値, var_右値) Then
                col_出力.Add Array("＜基準⇔比較＞", ws_基準.name, ws_基準.Cells(lng_行, lng_列).Address(False, False), _
                                   ws_基準.Cells(1, lng_列).Value, _
                                   "値不一致（左:" & var_左値 & "／右:" & var_右値 & "）")
            End If
            
            ' 書式差分をチェックする
            If bool_書式差分検出 Then
                If Not is_書式等しい(ws_基準.Cells(lng_行, lng_列), ws_比較.Cells(lng_行, lng_列)) Then
                    col_出力.Add Array("＜基準⇔比較＞", ws_基準.name, ws_基準.Cells(lng_行, lng_列).Address(False, False), _
                                       ws_基準.Cells(1, lng_列).Value, _
                                       "書式不一致")
                End If
            End If
        Next lng_列
    Next lng_行
End Sub


'----------------------------------------------------------
' is_値等しい
' 機能概要 : 数値・文字・日付を考慮して2値を比較
' 引数　　: var_A / var_B（Variant）
' 戻り値　: Boolean（等しい=True）
' YYYY/MM/DD 名前
'----------------------------------------------------------
Private Function is_値等しい(ByVal var_A As Variant, ByVal var_B As Variant) As Boolean
    ' 数値同士の比較を行う
    If IsNumeric(var_A) And IsNumeric(var_B) Then
        is_値等しい = (Abs(CDbl(var_A) - CDbl(var_B)) <= dbl_許容誤差)
    ' 日付同士の比較を行う
    ElseIf IsDate(var_A) And IsDate(var_B) And bool_日付同値扱い Then
        is_値等しい = (Abs(CDbl(CDate(var_A)) - CDbl(CDate(var_B))) < 0.0000001)
    ' 文字列の比較を行う
    Else
        Dim str_A As String, str_B As String
        str_A = CStr(var_A): str_B = CStr(var_B)
        ' TRIM比較の設定を適用する
        If bool_TRIM比較 Then
            str_A = Trim$(str_A): str_B = Trim$(str_B)
        End If
        ' 大文字小文字区別の設定を適用する
        If Not bool_大文字小文字区別 Then
            str_A = LCase$(str_A): str_B = LCase$(str_B)
        End If
        is_値等しい = (str_A = str_B)
    End If
End Function


'----------------------------------------------------------
' is_シート存在
' 機能概要 : 指定ブック内にシート名が存在するか判定
' 引数　　: wb_対象（Workbook）
'             str_シート名（String）
' 戻り値　: Boolean（存在=True）
' YYYY/MM/DD 名前
'----------------------------------------------------------
Private Function is_シート存在(ByVal wb As Workbook, ByVal name As String) As Boolean
      Dim ws As Worksheet
      
      On Error Resume Next
      Set ws = wb.Worksheets(name)
      is_シート存在 = Not ws Is Nothing
      On Error GoTo 0
End Function


'----------------------------------------------------------
' is_書式等しい
' 機能概要 : 2つのセルの書式が等しいか判定
' 引数　　: rng_A / rng_B（Range）
' 戻り値　: Boolean（等しい=True）
' YYYY/MM/DD 名前
'----------------------------------------------------------
Private Function is_書式等しい(ByVal rng_A As Range, ByVal rng_B As Range) As Boolean
    ' フォント書式を比較する
    If rng_A.Font.Bold <> rng_B.Font.Bold Or _
       rng_A.Font.Italic <> rng_B.Font.Italic Or _
       rng_A.Font.Underline <> rng_B.Font.Underline Or _
       rng_A.Font.Color <> rng_B.Font.Color Or _
       rng_A.Font.Size <> rng_B.Font.Size Or _
       rng_A.Font.name <> rng_B.Font.name Then
        is_書式等しい = False
        Exit Function
    End If
    
    ' セルの背景色を比較する
    If rng_A.Interior.Color <> rng_B.Interior.Color Then
        is_書式等しい = False
        Exit Function
    End If
    
    ' 罫線を比較する
    If rng_A.Borders(xlEdgeLeft).LineStyle <> rng_B.Borders(xlEdgeLeft).LineStyle Or _
       rng_A.Borders(xlEdgeRight).LineStyle <> rng_B.Borders(xlEdgeRight).LineStyle Or _
       rng_A.Borders(xlEdgeTop).LineStyle <> rng_B.Borders(xlEdgeTop).LineStyle Or _
       rng_A.Borders(xlEdgeBottom).LineStyle <> rng_B.Borders(xlEdgeBottom).LineStyle Then
        is_書式等しい = False
        Exit Function
    End If
    
    ' 数値書式を比較する
    If rng_A.NumberFormat <> rng_B.NumberFormat Then
        is_書式等しい = False
        Exit Function
    End If
    
    ' 水平配置を比較する
    If rng_A.HorizontalAlignment <> rng_B.HorizontalAlignment Then
        is_書式等しい = False
        Exit Function
    End If
    
    ' 垂直配置を比較する
    If rng_A.VerticalAlignment <> rng_B.VerticalAlignment Then
        is_書式等しい = False
        Exit Function
    End If
    
    is_書式等しい = True
End Function


'==========================================================
' モジュール名：mod_UI_FolderSelect
' 機能概要　　：基準／比較フォルダのパスを参照ダイアログで選択
'==========================================================

'----------------------------------------------------------
' run_RefFolder1_Click
' 機能概要 : 基準フォルダのパスを選択し、B2セルに反映する
' 引数　　: なし
' 戻り値　: なし
' YYYY/MM/DD 名前
'----------------------------------------------------------
Public Sub run_RefFolder1_Click()
    Dim ws_UI As Worksheet: Set ws_UI = Worksheets("DiffUI")
    Dim str_パス As String
    str_パス = get_フォルダパス("基準フォルダを選択してください")
    If Len(str_パス) > 0 Then ws_UI.Range("B2").Value = str_パス
End Sub


'----------------------------------------------------------
' run_RefFolder2_Click
' 機能概要 : 比較フォルダのパスを選択し、B3セルに反映する
' 引数　　: なし
' 戻り値　: なし
' YYYY/MM/DD 名前
'----------------------------------------------------------
Public Sub run_RefFolder2_Click()
    Dim ws_UI As Worksheet: Set ws_UI = Worksheets("DiffUI")
    Dim str_パス As String
    str_パス = get_フォルダパス("比較フォルダを選択してください")
    If Len(str_パス) > 0 Then ws_UI.Range("B3").Value = str_パス
End Sub


'----------------------------------------------------------
' get_フォルダパス
' 機能概要 : フォルダ選択ダイアログを表示し、選択されたパスを返す
' 引数　　: str_タイトル（String） … ダイアログのタイトル
' 戻り値　: String（選択フォルダパス／未選択時は空文字）
' YYYYMM/DD 名前
'----------------------------------------------------------
Private Function get_フォルダパス(ByVal str_タイトル As String) As String
    Dim fd_ダイアログ As FileDialog
    Set fd_ダイアログ = Application.FileDialog(msoFileDialogFolderPicker)
    With fd_ダイアログ
        .Title = str_タイトル
        .AllowMultiSelect = False
        If .Show = -1 Then
            get_フォルダパス = .SelectedItems(1)
        Else
            get_フォルダパス = ""
        End If
    End With
End Function




'==========================================================
' モジュール名：mod_UI_Create
' 機能概要　　：DiffUIシートの作成およびボタン生成を行う
'==========================================================

'----------------------------------------------------------
' run_作成_UIシート
' 機能概要 : DiffUIシートを新規作成し、見出し・オプション列・ボタンを配置する
' 引数　　: なし
' 戻り値　: なし
' YYYY/MM/DD 名前
'----------------------------------------------------------
Public Sub run_作成_UIシート()
    Dim ws_UI As Worksheet
    
    ' 既存のDiffUIシートを削除する
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("DiffUI").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0

    ' 新しいシートを作成する
    Set ws_UI = Worksheets.Add(After:=Worksheets(Worksheets.Count))
    ws_UI.name = "DiffUI"

    ' 見出しと構造を設定する
    With ws_UI
        .Range("A1").Value = "Excel差分ツール（フォルダ比較：全ファイル×全シート）"
        .Range("A1").Font.Bold = True
        .Range("A1").Font.Size = 14
        .Range("A2").Value = "Target1（基準フォルダ）"
        .Range("A3").Value = "Target2（比較フォルダ）"
        .Range("A5").Resize(1, 5).Value = Array("ファイル", "シート", "セル", "列見出し", "不一致理由")
        .Rows(5).Font.Bold = True
        .Columns("A:E").AutoFit
    End With

    ' オプション設定列を配置する
    With ws_UI
        .Cells(1, 7).Value = "許容誤差": .Cells(2, 7).Value = 0.000001
        .Cells(1, 8).Value = "大文字小文字区別": .Cells(2, 8).Value = "FALSE"
        .Cells(1, 9).Value = "TRIM比較": .Cells(2, 9).Value = "TRUE"
        .Cells(1, 10).Value = "拡張子パターン": .Cells(2, 10).Value = "*.xlsx;*.xlsm"
        .Cells(1, 11).Value = "日付同値扱い": .Cells(2, 11).Value = "FALSE"
        .Cells(1, 12).Value = "書式差分検出": .Cells(2, 12).Value = "FALSE"
        .Cells(1, 13).Value = "シート名で比較": .Cells(2, 13).Value = "TRUE"
        .Range("G1:M1").Font.Bold = True
        .Columns("G:M").AutoFit
    End With

    ' ボタンを生成する
    call_追加_ボタン図形 ws_UI, "btnRef1", "参照1（基準フォルダ）", 20, 34, 160, 24, "run_RefFolder1_Click"
    call_追加_ボタン図形 ws_UI, "btnRef2", "参照2（比較フォルダ）", 190, 34, 160, 24, "run_RefFolder2_Click"
    call_追加_ボタン図形 ws_UI, "btnDiff", "比較実行（全ファイル×全シート）", 360, 34, 230, 24, "run_DiffFolders_Click"

    MsgBox "UIシートを作成しました。フォルダを選択して比較を開始できます。", vbInformation
End Sub


'----------------------------------------------------------
' call_追加_ボタン図形
' 機能概要 : 指定位置に角丸ボタン図形を作成し、マクロを割り当てる
' 引数　　: ws_対象（Worksheet）  … ボタンを追加するシート
'           str_名前（String）      … ボタン名
'           str_表示名（String）    … 表示テキスト
'           sng_Left/Top/Width/Height（Single）… 位置とサイズ
'           str_マクロ名（String）  … 割当マクロ名
' 戻り値　: なし
' YYYY/MM/DD 名前
'----------------------------------------------------------
Private Sub call_追加_ボタン図形( _
        ByVal ws_対象 As Worksheet, _
        ByVal str_名前 As String, _
        ByVal str_表示名 As String, _
        ByVal sng_Left As Single, _
        ByVal sng_Top As Single, _
        ByVal sng_Width As Single, _
        ByVal sng_Height As Single, _
        ByVal str_マクロ名 As String)

    Dim shp_ボタン As Shape
    Set shp_ボタン = ws_対象.Shapes.AddShape(msoShapeRoundedRectangle, sng_Left, sng_Top, sng_Width, sng_Height)
    
    With shp_ボタン
        .name = str_名前
        .TextFrame2.TextRange.Text = str_表示名
        .Fill.ForeColor.RGB = RGB(230, 230, 250)
        .Line.ForeColor.RGB = RGB(120, 120, 160)
        .TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
        .TextFrame2.VerticalAnchor = msoAnchorMiddle
        .OnAction = "'" & ThisWorkbook.name & "'!" & str_マクロ名
    End With
End Sub