[Excel]VBAで書式を変更する

アイキャッチVBAサンプル

前回の記事では「右クリックメニューの追加」を紹介しましたが、今回はそのメニューに「書式の設定」を実装します。フォントと罫線の変更になりますが、応用は割と簡単にできると思うので、是非最後まで読んでみて下さい。

右クリックメニューに「書式を変更するメニュー」を追加

サブメニューに「書式の設定」を実装する

仕様は以下の通りです。

  • 実行する内容は「書式を [太字][赤色][赤色の下罫線(中太線)]にする」
  • 実行内容を解除(キャンセル)するメニューも作る

前回のサブメニューで「書式の設定」と「書式の解除」を実行できるようにします。「VBA 書式設定」で検索してもいまいちだったので以下のワードで探しました。

で、このサイトに辿り着きました。

多分に漏れず、サンプルを頂戴します(ありがとうございます)。 myMacro を書き換えます。

書式変更サンプル

Sub myMacro() 'マクロ名
    With Range("A1").Font 'A1セルのフォントを取得
        .Name = "MS明朝" 'フォントの種類を変更
        .Bold = True '太字に変更
        .Color = vbRed '赤色に変更
        .FontStyle = "斜体" '斜体に変更
        .OutlineFont = True 'これは無視して下さい
        .Size = 16 'サイズを16に変更
    End With
End Sub

A1セルの書式を変更するコードになっているので、あらかじめA1セルに何かを入力しておきます。

書式変更サンプル

Sample1を実行し、サブメニューのmyMacroを選択すると、A1セルのフォントが変更されました。

先ほどのサイトに「罫線の変更」もサンプルがあったので引き続き改造してみます。サンプルで不要だった書式設定も削除します。

罫線変更追加

Sub myMacro() 'マクロ名
    With Range("A1").Font 'A1セルのフォントを取得
        .Bold = True '太字に変更
        .Color = vbRed '赤色に変更
        End With
    With Range("A1").Borders(xlEdgeBottom) 'A1セルの罫線を取得
        .Color = vbRed '赤色に変更
        .Weight = xlMedium '中太線に変更
    End With
End Sub
書式変更罫線追加

Sample1を実行し、サブメニューのmyMacroを選択すると、A1セルのフォントが変更に加え、下罫線も追加されました。

もう一つのサブメニューに「書式の解除」を実装する

もう一つのサブメニューボタンで「書式の解除」を実行できるようにします。これは元に戻すだけなのでコードは myMacro がそのまま流用できそうです。

書式変更解除

Sub myMacro1() 'マクロ名
    With Range("A1").Font 'A1セルのフォントを取得
        .Bold = False '太字を解除
        .Color = vbBlack '黒色に変更
    End With
    Range("A1").Borders(xlEdgeBottom).LineStyle = xlLineStyleNone '罫線を消す
End Sub

6行目のコードがmyMacroと若干変わっています。罫線を元の状態に戻すという事は「消す」事になります。ググるとLineStyle = xlLineStyleNoneで消せる事がわかりました。ググりついでに「書式をクリア」できる事もわかりました。Range(“A1”).ClearFormatsでフォント含めて全ての書式設定がクリアできるので便利と思ったのですが、太字や色以外も全てクリアされてしまうので、フォントの「種類」や「サイズ」を変えて利用する事ができなくなります。この辺は仕様とにらめっこしながら適切なコードを使用する必要があります。

書式変更解除

Sample1を実行し、サブメニューのmyMacro1を選択すると、A1セルのフォントが元の状態に戻りました。

選択したセルでマクロを実行する

このままではA1セルしか変更できないので、選択したセルでマクロが実行できるようにします。

検索上位を読んでみてもピンとこないですね。ただ読んでみて何となくわかったのですが、いま求めている事は「セルを選択する」事ではなく、「選択されたセル」をどうにかしたい訳です。ちょっとググり方を変えてみました。

おっと、お目当てのサイトが見つかったようです。

Selectionプロパティ を使えと書いてあります。Range(“A1”)Selectionに置き換えたら動きそうな気配(適当)。やってみましょう。

選択したセルでマクロ実行

Sub myMacro() 'マクロ名
    With Selection.Font '選択したセルのフォントを取得
        .Bold = True '太字に変更
        .Color = vbRed '赤色に変更
        End With
    With Selection.Borders(xlEdgeBottom) '選択したセルの罫線を取得
        .Color = vbRed '赤色に変更
        .Weight = xlMedium '中太線に変更
    End With
End Sub

Sub myMacro1() 'マクロ名
    With Selection.Font '選択したセルのフォントを取得
        .Bold = False '太字を解除
        .Color = vbBlack '黒色に変更
    End With
    Selection.Borders(xlEdgeBottom).LineStyle = xlLineStyleNone '選択したセルの罫線を消す
End Sub
書式変更下罫線のみ

適当なセルに何か入力し、そこを選択した状態で右クリックからmyMacroを選択すると、書式が設定されました。同じくmyMacroを選択すると書式が解除されました。が…

できました。と言いたいところですが不十分でした。複数範囲を選択した時、罫線の設定が範囲の一番下しか変更されません。そりゃそうですよね、「下罫線」ですから。つまり「中罫線」も設定してやれば解決するのではないでしょうか?

複数範囲選択でもOKなやつ

Sub myMacro() 'マクロ名
    With Selection.Font '選択したセルのフォントを取得
        .Bold = True '太字に変更
        .Color = vbRed '赤色に変更
        End With
    With Selection.Borders(xlEdgeBottom) '選択したセルの下罫線を取得
        .Color = vbRed '赤色に変更
        .Weight = xlMedium '中太線に変更
    End With
    With Selection.Borders(xlInsideHorizontal) '選択したセルの中罫線を取得
        .Color = vbRed '赤色に変更
        .Weight = xlMedium '中太線に変更
    End With
End Sub

Sub myMacro1() 'マクロ名
    With Selection.Font '選択したセルのフォントを取得
        .Bold = False '太字を解除
        .Color = vbBlack '黒色に変更
    End With
    With Selection
        .Borders(xlEdgeBottom).LineStyle = xlLineStyleNone '選択したセルの下罫線を消す
        .Borders(xlInsideHorizontal).LineStyle = xlLineStyleNone '選択したセルの中罫線を消す
    End With
End Sub
書式変更中罫線追加

複数範囲を選択しても、全てのセルで「下罫線」が設定、解除できました。セルを一つしか選択していない状態でも問題ありません(中罫線でエラーになる事はない)

これで希望通りの動きになりました。ちなみにmyMacro1の21行目から23行目、With ~ End Withを使ってみました。これ、要は同じコードを何回も書かなくていい仕組みです。ここで省略できる部分を「オブジェクト」といいます(らしいです)。が、オブジェクトの理解は後回しにしましょう。ここではSelectionを省略している事が理解できればOKです。ちなみにこのWithステートメントを使わないで書くとこうなります。

Withステートメント無しサンプル

Sub myMacro() 'マクロ名
Selection.Font.Bold = True
Selection.Font.Color = vbRed
Selection.Borders(xlEdgeBottom).Color = vbRed
Selection.Borders(xlEdgeBottom).Weight = xlMedium
Selection.Borders(xlInsideHorizontal).Color = vbRed
Selection.Borders(xlInsideHorizontal).Weight = xlMedium
End Sub

Withステートメントを使ったコードと比較してもらえれば、何となく使い方がわかってくると思います。もしわからなければ使わなくても構いません。とにかく最初は「動けばいい」んです。

その他にもコントロール、プロパティ、メソッド、プロシージャ、等々意味不明な単語がググると溢れかえっていますが、これらを理解した上でVBAをスタートしようとするとつまづきます(※個人の感想です)。さわっていく内に理解できればいいぐらいの気持ちで私はVBAと付き合っています。

右クリックメニューに実装する

いよいよ実装です。前回のコードと今回のコードを組み合わせます。前回と今回のマクロ名は同じなのでsubプロシージャを丸ごと書き換えてやればOKです。

Worksheetイベントプロシージャ[sheet1]

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    On Error Resume Next
    CommandBars("Cell").Controls("Button").Delete
    With CommandBars("Cell").Controls.Add(Before:=1, Type:=msoControlPopup)
        .Caption = "Button"
            With .Controls.Add
                 .Caption = "myMacro"
                 .OnAction = "myMacro" 'subプロシージャの[myMacro]を実行する
            End With
            With .Controls.Add
                 .Caption = "myMacro1"
                 .OnAction = "myMacro1" 'subプロシージャの[myMacro1]を実行する
            End With
    End With
End Sub

Private Sub Worksheet_Deactivate()
    On Error Resume Next
    CommandBars("Cell").Controls("Button").Delete
End Sub

Workbookイベントプロシージャ

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    On Error Resume Next
    Application.CommandBars("Cell").Controls("Button").Delete
End Sub

Private Sub Workbook_Deactivate()
    On Error Resume Next
    Application.CommandBars("Cell").Controls("Button").Delete
End Sub
subプロシージャ(標準モジュール)

Sub myMacro()
    With Selection.Font
        .Bold = True
        .Color = vbRed
        End With
    With Selection.Borders(xlEdgeBottom)
        .Color = vbRed
        .Weight = xlMedium
    End With
     With Selection.Borders(xlInsideHorizontal)
        .Color = vbRed
        .Weight = xlMedium
    End With
End Sub

Sub myMacro1()
    With Selection.Font
        .Bold = False
        .Color = vbBlack
    End With
    With Selection
        .Borders(xlEdgeBottom).LineStyle = xlLineStyleNone
        .Borders(xlInsideHorizontal).LineStyle = xlLineStyleNone
    End With
End Sub

完成です。これで「右クリックメニュー」を作成し、「機能を実装する」事ができました。メニュー名と機能部分を変えてやれば今後も利用できそうです。みなさんも是非、チャレンジしてみて下さい。

おまけ

右クリックメニューでブラウザ起動

subプロシージャ(標準モジュール)


Sub myMacro() '既定のブラウザで起動
Dim default As Object
    Set default = CreateObject("WScript.Shell")
    chrome.Run Url & "https://m0ratorium.com/"
End Sub

Sub myMacro1() 'Edgeで起動
Dim edge As Object
    Set edge = CreateObject("WScript.Shell")
    edge.Run "microsoft-edge:" & "https://m0ratorium.com/"
End Sub

myMacroで既定のブラウザを起動できます。myMacro1でEdgeを指定して起動できます(既定のブラウザがEdgeの場合はどちらも同じ結果になります)。

右クリックメニューで矢印を引く

subプロシージャ(標準モジュール)

Sub myMacro() '片矢印を引く
Dim r, rStart, rEnd As Range
Dim iRowStart, iRowEnd, iColStart, iColEnd, iPairRow, iPairCol As Long
Dim dStartY, dStartX, dEndY, dEndX As Double
Set r = Selection
    iRowStart = Selection.Row
    iRowEnd = Selection.Rows.Count + iRowStart - 1
    iColStart = Selection.Column
    iColEnd = Selection.Columns.Count + iColStart - 1
Set rStart = ActiveCell
    If (rStart.Row = iRowStart) Then
        iPairRow = iRowEnd
    Else
        iPairRow = iRowStart
    End If
    If (rStart.Column = iColStart) Then
        iPairCol = iColEnd
    Else
        iPairCol = iColStart
    End If
Set rEnd = Cells(iPairRow, iPairCol)
    If (rStart.Left <= rEnd.Left) Then
        dStartX = rStart.Left
        dEndX = rEnd.Left + rEnd.Width
    Else
        dStartX = rStart.Left + rStart.Width
        dEndX = rEnd.Left
    End If
    dStartY = rStart.Top + (rStart.Height / 2)
    dEndY = rEnd.Top + (rEnd.Height / 2)
    ActiveSheet.Shapes.AddConnector(msoConnectorStraight, dStartX, dStartY, dEndX, dEndY).Select
    Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadTriangle
    Selection.ShapeRange.Line.ForeColor.RGB = RGB(0, 0, 0)
    Selection.ShapeRange.Line.Weight = 1.5
    r.Select
End Sub

Sub myMacro1() '両矢印を引く
Dim r, rStart, rEnd As Range
Dim iRowStart, iRowEnd, iColStart, iColEnd, iPairRow, iPairCol As Long
Dim dStartY, dStartX, dEndY, dEndX As Double
Set r = Selection
    iRowStart = Selection.Row
    iRowEnd = Selection.Rows.Count + iRowStart - 1
    iColStart = Selection.Column
    iColEnd = Selection.Columns.Count + iColStart - 1
Set rStart = ActiveCell
    If (rStart.Row = iRowStart) Then
        iPairRow = iRowEnd
    Else
        iPairRow = iRowStart
    End If
    If (rStart.Column = iColStart) Then
        iPairCol = iColEnd
    Else
        iPairCol = iColStart
    End If
Set rEnd = Cells(iPairRow, iPairCol)
    If (rStart.Left <= rEnd.Left) Then
        dStartX = rStart.Left
        dEndX = rEnd.Left + rEnd.Width
    Else
        dStartX = rStart.Left + rStart.Width
        dEndX = rEnd.Left
    End If
    dStartY = rStart.Top + (rStart.Height / 2)
    dEndY = rEnd.Top + (rEnd.Height / 2)
    ActiveSheet.Shapes.AddConnector(msoConnectorStraight, dStartX, dStartY, dEndX, dEndY).Select
    Selection.ShapeRange.Line.BeginArrowheadStyle = msoArrowheadTriangle
    Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadTriangle
    Selection.ShapeRange.Line.ForeColor.RGB = RGB(0, 0, 0)
    Selection.ShapeRange.Line.Weight = 1.5
    r.Select
End Sub
右クリック片矢印

myMacroで片矢印を引きます。範囲指定可能です。

右クリック両矢印

myMacro1で両矢印を引きます。同じく範囲指定可能です。

右クリックで実行するプロシージャをググって拾いましょう。色々な機能が実装できます。

よかったら元になったカレンダーをダウンロードしてみて下さい。

では、最後までご高覧いただきありがとうございました。

タイトルとURLをコピーしました