'
' 書式パレットマクロブックの作成手順
'
' 1. 作業用のブックを新規作成しモジュールシートを２つ新規作成します。
'    シート名は必ず Module1 とModule2 にしてください。
' 2. 以下のマクロを Module1 のシートにコピーします。
'    Module2の内容は下の方にあります。
' 3. Module2のStartプロシージャを実行してマクロのブックを作成します。
' 4. 1で作成した作業用ブックを削除します。
' 5. マクロのブックを保存し閉じ、もう一度開くと、ワークシートの
'    ショートカットメニューに書式パレットメニューが現れます。
'    書式パレットシート上の各書式は自由に変更できます。
' 6. コードを一部削除し、メニューエディタでメニュー登録することもできます。
'    マクロのブックはそのままでも、アドインにしても利用できます。
'
'*******************************************************************
' 以下がModule1の内容です。
'*******************************************************************
'
' 書式パレットマクロ
' Date: 1996/05/01  Author: Kazuyuki Housaka
'
Option Explicit

Const SheetName = "書式パレット"
Const MaxCount = 5

Sub FormatPalette(idx As Integer)
    Dim sht1 As Worksheet
    Dim rng1 As Range, rng2 As Range, r As Range

    If TypeName(Selection) <> "Range" Then
        MsgBox "セル範囲が選択されていません。", vbCritical, "書式パレット"
        Exit Sub
    End If

    Application.ScreenUpdating = False
    Set rng2 = Selection
    Set sht1 = ThisWorkbook.Worksheets(SheetName)
    Set rng1 = sht1.Cells(idx * 2, 2)
    rng1.Cells(1, 1).Copy
    rng2.Worksheet.Activate
    rng2.PasteSpecial Paste:=xlFormats
    
    rng2.Borders.LineStyle = xlNone
    For Each r In rng2.Areas
        BorderAroundCopy rng1, r
    Next
End Sub

Sub BorderAroundCopy(rng1 As Range, rng2 As Range)
    Dim rng1First As Range, rng1Last As Range

    Set rng1First = rng1.Cells(1, 1)
    Set rng1Last = rng1.Cells(rng1.Rows.Count, rng1.Columns.Count)

    With rng2.Rows(1).Borders(xlTop)
        .LineStyle = rng1First.Borders(xlTop).LineStyle
        If rng1First.Borders(xlTop).LineStyle = xlContinuous Then
            .Weight = rng1First.Borders(xlTop).Weight
        End If
        .ColorIndex = rng1First.Borders(xlTop).ColorIndex
    End With
    With rng2.Rows(rng2.Rows.Count).Borders(xlBottom)
        .LineStyle = rng1Last.Borders(xlBottom).LineStyle
        If rng1Last.Borders(xlBottom).LineStyle = xlContinuous Then
            .Weight = rng1Last.Borders(xlBottom).Weight
        End If
        .ColorIndex = rng1Last.Borders(xlBottom).ColorIndex
    End With
    With rng2.Columns(1).Borders(xlLeft)
        .LineStyle = rng1First.Borders(xlLeft).LineStyle
        If rng1First.Borders(xlLeft).LineStyle = xlContinuous Then
            .Weight = rng1First.Borders(xlLeft).Weight
        End If
        .ColorIndex = rng1First.Borders(xlLeft).ColorIndex
    End With
    With rng2.Columns(rng2.Columns.Count).Borders(xlRight)
        .LineStyle = rng1Last.Borders(xlRight).LineStyle
        If rng1Last.Borders(xlRight).LineStyle = xlContinuous Then
            .Weight = rng1Last.Borders(xlRight).Weight
        End If
        .ColorIndex = rng1Last.Borders(xlRight).ColorIndex
    End With
    rng2.BorderAround LineStyle:=xlNone
End Sub

' 以下のマクロはブックのオープン時にショートカットメニューへ
' FormatPaletteマクロを登録します。
' メニューエディタでマクロを登録する場合は以下を削除してください。
'
Sub Auto_Open()
    MenuAdd1
End Sub

Sub Auto_Close()
    MenuDelete1
End Sub

Sub MenuAdd1()
    Dim i As Integer
    Dim sht1 As Worksheet
    Set sht1 = ThisWorkbook.Worksheets(SheetName)
    With ShortcutMenus(xlWorksheetCell)
        With .MenuItems.AddMenu(Caption:=SheetName)
            For i = 1 To MaxCount
                .MenuItems.Add _
                    Caption:=sht1.Cells(i * 2, 1).Value, _
                    OnAction:="'FormatPalette " & i & "'"
            Next
        End With
    End With
End Sub

Sub MenuDelete1()
    Dim i As Integer, j As Integer
    Dim mnu As Menu
    With ShortcutMenus(xlWorksheetCell)
        Set mnu = Nothing
        On Error Resume Next
        Set mnu = .MenuItems(SheetName)
        On Error GoTo 0
        If mnu Is Nothing Then Exit Sub
        j = mnu.MenuItems.Count
        For i = j To 1 Step -1
            mnu.MenuItems(i).Delete
        Next
        mnu.Delete
    End With
End Sub

Sub MenuReset()
    MenuDelete1
    MenuAdd1
End Sub

'
'*******************************************************************
' 以下がModule2 の内容です。
'*******************************************************************
'
' 書式パレットマクロブックを作成するマクロ
' Date: 1996/12/01  Author: Kazuyuki Housaka
'
Sub Start()
    Dim wkb As Workbook
    Dim sht As Object
    Set wkb = Workbooks.Add
    wkb.SaveAs fileName:="FRMTPAL.XLS"
    ThisWorkbook.Activate
    Sheets("Module1").Copy Before:=wkb.Sheets(1)
    wkb.Activate
    CreateWorksheet
    Application.DisplayAlerts = False
    For Each sht In Sheets
       Select Case sht.Name
           Case "Module1", "書式パレット"
           Case Else
               sht.Delete
        End Select
    Next
End Sub

Sub CreateWorksheet()
    Worksheets.Add
    ActiveSheet.Name = "書式パレット"
    Range("A1").Formula = "書式名"
    Range("B1").Formula = "書式"
    Range("A2").Formula = "書式1"
    Range("A4").Formula = "書式2"
    Range("A6").Formula = "書式3"
    Range("A8").Formula = "書式4"
    Range("A10").Formula = "書式5"
    Range("D1").Formula = "＜書式の変更について＞"
    Range("D2").Formula = "書式名と書式は変更できます。"
    Range("D3").Formula = _
    "シート名も変更できますが、コード中の Const SheetName = と必ず同一にしてください。"
    Range("D4").Formula = _
    "メニューの変更はブックの再オープンかMenuReset()の実行により有効になります。"
    Range("D5").Formula = _
    "書式の登録数はコード中のConst MaxCount = の数値で変更できます。"
    Range("D6").Formula = "罫線は外枠線のみ有効です。"

    With Range("B2,B4,B6,B8,B10")
        .Formula = "ABC"
    End With
    With Range("B4,B6,B8,B10")
        .HorizontalAlignment = xlCenterAcrossSelection
        .BorderAround Weight:=xlMedium, ColorIndex:=xlAutomatic
    End With
    Range("B4").Interior.ColorIndex = 35
    Range("B6").Interior.ColorIndex = 24
    Range("B8").Interior.ColorIndex = 15
    Range("B10").Interior.ColorIndex = 19
    Range("B10").Font.ColorIndex = 3
    Range("A1").Select
End Sub

'*******************************************************************