Excel VBA セルの書式を他のセル範囲に適用する汎用ツール

'「見本セル」の書式設定を指定セル範囲に設定する
Sub FormattingCells()
    Dim rn As Range
    Dim sh As Worksheet
    Dim oldList As Variant
    Dim chk(27) As Variant
    Dim i As Long, j As Long
    Dim sr As Long, sc As Long, er As Long, ec As Long
 
    For i = 1 To 27
        chk(i) = Cells(i + 1, 2).Value
    Next

    On Error Resume Next
    Set rn = Application.InputBox( _
                Prompt:="設定対象範囲（表）の先頭セルを選択してください！" _
                & vbCrLf & "または、対象セル範囲を選択指定してください！" _
                , Title:="書式設定セル範囲選択", Type:=8)
    On Error GoTo 0
    If rn Is Nothing Then Exit Sub
    Set sh = rn.Worksheet
    
    sh.Activate    '元シートの設定を調べる
    sr = rn.Row       '開始行取得
    sc = rn.Column    '開始列取得
    '取得セル範囲を2次元配列に一括代入する
    If rn.Count = 1 Then
        'セル選択が1個の場合
        '元シートの最終行列取得
        er = sr + sh.Cells(sr, sc).CurrentRegion.Rows.Count - 1
        ec = sc + sh.Cells(sr, sc).CurrentRegion.Columns.Count - 1
        'セル範囲データを配列に入れる
        oldList = sh.Range(Cells(sr, sc), Cells(er, ec)).Value
    Else
        'セルを複数（範囲で）選択している場合
        oldList = rn.Value
    End If
    Set rn = Nothing
    
    '差分があった場合のセル配色などを設定
    Dim a As Variant
    a = Split(GetCellsFormat, ",")
    If IsArray(a) = False Then GoTo Ex
    
    Application.ScreenUpdating = False              '画面描画を停止
    Application.Calculation = xlCalculationManual   '計算を手動に
    '対象シートを基準でループ
    On Error Resume Next    'エラー発生時（データが無い）止めない
    For i = 1 To UBound(oldList, 1)
        For j = 1 To UBound(oldList, 2)
            With sh.Cells(i + sr - 1, j + sc - 1)
                If chk(24) = 1 Then .Borders.LineStyle = False    '線の種類
                If chk(1) = 1 Then .NumberFormatLocal = a(1) '書式
                If chk(2) = 1 Then .HorizontalAlignment = Val(a(2)) '横位置
                If chk(3) = 1 Then .VerticalAlignment = Val(a(3))  '縦位置
                If chk(4) = 1 Then .AddIndent = CBool(a(4))    '前後にスペースを入れる
                If chk(5) = 1 Then .IndentLevel = Val(a(5))    'インデント
                If chk(6) = 1 Then .WrapText = CBool(a(6))       '折り返して全体を表示する
                If chk(7) = 1 Then .ShrinkToFit = CBool(a(7))    '縮小して全体を表示する
                If chk(8) = 1 Then .MergeCells = CBool(a(8))     'セルを結合する
                If chk(9) = 1 Then .ReadingOrder = Val(a(9))   '文字の方向
                If chk(10) = 1 Then .Orientation = Val(a(10))    '方向の角度
                If chk(11) = 1 Then .Font.Color = Val(a(11))     '文字色
                If chk(12) = 1 Then .Font.Name = a(12)      'フォント名前
                If chk(13) = 1 Then .Font.Size = Val(a(13))      'サイズ
                If chk(14) = 1 Then .Font.Bold = CBool(a(14))      '太字
                If chk(15) = 1 Then .Font.Italic = CBool(a(15))        '斜体イタリック
                If chk(16) = 1 Then .Font.Underline = Val(a(16))     '下線
                If chk(17) = 1 Then .Font.Strikethrough = CBool(a(17)) '取り消し線
                If chk(18) = 1 Then .Font.Superscript = CBool(a(18))   '上付き文字
                If chk(19) = 1 Then .Font.Subscript = Val(a(19))     '下付き文字
                If chk(20) = 1 Then .Borders.Color = Val(a(20))      '罫線の色
                If chk(21) = 1 Then
                    .Borders.Weight = Val(a(21))                '線の太さ全般
                    .Borders(xlEdgeTop).Weight = Val(a(21))     '上側罫線の太さ
                    .Borders(xlEdgeLeft).Weight = Val(a(21))    '左側罫線の太さ
                End If
                If chk(22) = 1 Then .Borders(xlDiagonalDown).LineStyle = Val(a(22))  '左上隅から右下への罫線
                If chk(23) = 1 Then .Borders(xlDiagonalUp).LineStyle = Val(a(23)) '左下隅から右上への罫線
                If chk(24) = 1 Then .Borders.LineStyle = Val(a(24))  '線の種類
                If chk(25) = 1 Then .Interior.Color = Val(a(25))     '背景色
                If chk(26) = 1 Then .Interior.Pattern = Val(a(26))   'パターン
                If chk(27) = 1 Then .Locked = CBool(a(27))         '保護設定
            End With
        Next j
    Next i
    On Error GoTo 0
    Application.Calculation = xlCalculationAutomatic '計算を自動に
    Application.ScreenUpdating = True               '画面描画を開始
Ex:
    Set sh = Nothing

End Sub

'指定セルの書式取得用関数
Function GetCellsFormat() As Variant
    Dim rn As Range
    Dim a As Variant
 
    On Error Resume Next
    Set rn = Application.InputBox( _
                Prompt:="「見本となる」セルを選択してください！" _
                , Title:="見本セル選択", Type:=8)
    On Error GoTo 0
    If rn Is Nothing Then Exit Function

    a = "0"     '配列0用データをセット
    '【セルの書式設定を取得】
    With rn '.Cells(1, 1)
        a = a & "," & .NumberFormatLocal    '表示形式
        a = a & "," & .HorizontalAlignment  '文字横位置
        a = a & "," & .VerticalAlignment    '文字縦位置
        a = a & "," & .AddIndent    '前後にスペースを入れる
        a = a & "," & .IndentLevel  'インデント
        a = a & "," & .WrapText     '折り返して全体を表示する
        a = a & "," & .ShrinkToFit  '縮小して全体を表示する
        a = a & "," & .MergeCells   'セルを結合する
        a = a & "," & .ReadingOrder '文字の方向
        a = a & "," & .Orientation  '方向の角度
        a = a & "," & .Font.Color   '文字色
        a = a & "," & .Font.Name    'フォント名
        a = a & "," & .Font.Size    'サイズ
        a = a & "," & .Font.Bold    '太字
        a = a & "," & .Font.Italic       '斜体
        a = a & "," & .Font.Underline    '下線
        a = a & "," & .Font.Strikethrough   '取り消し線
        a = a & "," & .Font.Superscript     '上付き文字
        a = a & "," & .Font.Subscript       '下付き文字
        a = a & "," & .Borders.Color    '罫線色
        a = a & "," & .Borders.Weight   '罫線太さ
        a = a & "," & .Borders(xlDiagonalDown).LineStyle '左上隅から右下への罫線
        a = a & "," & .Borders(xlDiagonalUp).LineStyle '左下隅から右上への罫線
        a = a & "," & .Borders.LineStyle '罫線種類（これは一番最後にすること）
        a = a & "," & .Interior.Color   '背景色
        a = a & "," & .Interior.Pattern 'パターン
        a = a & "," & .Locked           '保護設定
    End With

    GetCellsFormat = a

End Function