LoginSignup
9
13

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

More than 1 year has passed since last update.

@wdnuki(和狸)

Excel業務効率化マクロコレクション

Last updated at Posted at 2022-05-07

はじめに

言うまでもなくMicrosoft Excelは非常に有用なアプリケーションです。
昨今では大抵のPCにはインストールされていますし、
様々な現場で様々な使われ方をしているかと思います。

筆者は職業柄、1日の半分以上Excelを触っていることも珍しくありません。
また近年ではテレワークが多いのですが、テキストや数字、イラストを使って
画面共有先の仲間に考えを伝えたい、そんなときもExcelはとても有用だったりします。

すなわちこのExcel作業を効率化できれば業務全体の効率化につながり、
さらには他人に魅せるExcelとしても活用の幅が広がるのではないでしょうか。

個人的Excelマクロでできること

今回公開するマクロ集では、

  1. 選択したセルに合わせて赤枠オートシェイプをつける
  2. 選択したセルに合わせて矢印オートシェイプを作成する
  3. ちょっとおしゃれな吹き出しオートシェイプを作成する
  4. 値貼り付け
  5. 数式貼り付け
  6. 全シートの拡大率を100%に、かつA1セルが選択された状態にする

がショートカットキー（もしくはワンクリック）1つで出来ます。
この記事ではそんなマクロ集をまとめて公開するので、コピペだけで使えるようになります。

image.png

テレワークでの画面共有先には少なからず遅延が発生しているので、マウスカーソルで指しながら一生懸命説明してもカーソルが遅れて伝わります。そんな時、パッと赤枠などで注目箇所を指し示したりできるのでおすすめです。

ちょっと待って

Q. Excelマクロは使いたい（使ってみたい）けど、
保存したときにマクロ機能有効ブック（.xlsm）になってしまわない？
　　 　　⇓
A. 個人用マクロを使うので問題ありません。（元の拡張子のままでOKです。）

とりあえず導入してみて(Windowsの場合)

[1] 個人用Excelマクロの作成

  1. [開発]タブの表示
  2. [開発] > コード > 「マクロの記録」
  3. マクロの保存先を「個人用マクロブック」に設定
  4. 何もせずに「記録終了」を押下

これで「PERSONAL.XLSB」が作成されます。

ちなみに筆者(Windows 10)の場合は以下にファイルの実体が作成されていました。
あまり意識する必要はありません。
＜ユーザー名＞\AppData\Roaming\Microsoft\Excel\XLSTART

なお、すでに個人マクロの設定方法について詳しく書かれている方がいらっしゃるので
導入過程でつまづいたらこちらを参考ください。
個人用マクロブックのすすめ～入門編～

[2] 個人用マクロの導入

　1. VBAProject（PERSONAL.XLSB）内に標準モジュールを作成する
　2. 以下のソースをコピー＆ペーストする

(A) 個人Excelマクロ（PERSONAL.XLSB）
PERSONAL.XLSB（WdnukiMacros）

' ****************************************************************
' * WELCOME TO WDNUKI MACROS!
' * Excelを使用するにあたり便利な個人マクロのコレクションです。
' * 赤枠作成や値貼り付け、手順書テンプレート作成など。
' * PERSONAL.xlsbに登録し、任意でショートカットキーや
' * クイックアクセスツールに登録してください。
' *
' ****************************************************************

' ***SETTING***************************************
' * 各種設定を行なってください。
' *************************************************

' *** 標準フォント ***
Const STANDARD_FONT_NAME = "Meiryo UI"

' *** 標準フォントサイズ ***
Const STANDARD_FONT_SIZE = 11

' *** ショートカットキーの割り当て ***
Function AssignShortcutKey()

    '「Ctrl + Alt + Z」を「CreateRedFrame」に割り当てる
    Application.OnKey "^%z", "CreateRedFrame"
    
     '「Ctrl + Alt + A」を「CreateRedArrow」に割り当てる
    Application.OnKey "^%a", "CreateRedArrow"
    
    '「Ctrl + Alt + X」を「CreateFukidashi」に割り当てる
    Application.OnKey "^%x", "CreateFukidashi"
    
    ' 「Ctrl + Shift + V」を「ValuePaste」に割り当てる
    Application.OnKey "^+V", "ValuePaste"
    
    ' 「Ctrl + Shift + D」を「FomulaPaste」に割り当てる
    Application.OnKey "^+D", "FomulaPaste"
    
End Function

' ***SETTING END************************************

' ********** A1_100%マクロ ********************************************
' *
' * 現在開いているExcelを全て拡大率100%にし、カーソルをA1にする。
' * かつ再左端のシートを表示した状態にする。
' *********************************************************************
Sub Cursor_A1()

    Dim ws As Worksheet
    
    ' **************************************
    ' ** メイン処理【START】****************
    ' **************************************
    
    ' 画面更新をOFF
    Application.ScreenUpdating = False
    
    ' 各シートを順番に見ていく
    For Each ws In Worksheets
    
        ' カーソルをA1に移動
        ws.Activate
        Range("A1").Select
        
        ' 表示位置を左上端に移動
        ActiveWindow.ScrollColumn = 1
        ActiveWindow.ScrollRow = 1
    
        ' 表示倍率を100％に戻す
        ActiveWindow.Zoom = 100
    Next ws
    
    ' **************************************
    ' ** 後処理【START】********************
    ' **************************************
    
    ' １枚目のシートに移動
    Sheets(1).Select
    
    '画面更新を再開
    Application.ScreenUpdating = True
    
    ' メッセージを表示
    MsgBox "拡大率100%かつA1処理が完了しました!"
    
End Sub

' ********** 数式貼り付けマクロ ******************************************
' *
' * 数式貼り付け（セル書式などは無し）を行なう。
' * ショートカットキーを割り当てる想定。
' ************************************************************************
Sub FomulaPaste()
    Dim vClip As Variant
    
    On Error Resume Next
    
    ' クリップボードから取得
    vClip = Application.ClipboardFormats
    If vClip(1) = True Then
        Beep
        Exit Sub
    End If
    
    ' 数式貼り付けを行なう
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    
 End Sub
 
' ********** 値貼り付けマクロ ********************************************
' *
' * 値貼り付け（セル書式などは無し）を行なう。
' * ショートカットキーを割り当てる想定。
' ************************************************************************
Sub ValuePaste()
    Dim vClip As Variant
    
    On Error Resume Next
    
    ' クリップボードから取得
    vClip = Application.ClipboardFormats
    If vClip(1) = True Then
        Beep
        Exit Sub
    End If
    
    ' 値貼り付けを行なう
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

    
 End Sub


' ********** 赤枠作成マクロ ********************************************
' *
' * 選択されたセルに赤枠を作成する。エビデンスや手順書整備用。
' * ショートカットキーを割り当てる想定。
' **********************************************************************
Sub CreateRedFrame()
    
    Dim width, height As Integer
    Dim leftTop, rightBottom As Range
    Dim square As shape
    
    ' **************************************
    ' ** 前処理【START】 *******************
    ' **************************************
    
    ' 左上セルの取得
    Set leftTop = activeCell
    
    ' 右上セルの取得（選択範囲のセルを数えLast番目が右下にあたる）
    Set rightBottom = Range(Selection(Selection.Count).Address(False, False))
    
    ' 幅の計算
    width = rightBottom.Offset(0, 1).Left - activeCell.Left
    
    ' 高さの計算
    height = rightBottom.Offset(1, 0).Top - activeCell.Top
    
    ' **************************************
    ' ** 赤枠の作成【START】****************
    ' **************************************
    
    ' シェイプの作成
    Set square = ActiveSheet.Shapes.AddShape(msoShapeRectangle, activeCell.Left, activeCell.Top, width, height)
    
    ' 塗りつぶしなし
    square.Fill.Visible = msoFalse
    
    ' **************************************
    ' ** オブジェクトの見た目調整【START】**
    ' **************************************
    
    ' 枠の設定
    With square.Line
        .Visible = msoTrue
        
        ' 枠色の設定
        .ForeColor.RGB = RGB(255, 0, 0)
        
        ' 透過率（0.0が不透明、1.0が透明）
        .Transparency = 0.3
        
        ' 枠の太さ
        .Weight = 3
        
    End With
    
    ' **************************************
    ' ** 後処理【START】 *******************
    ' **************************************

    ' 特になし

End Sub
' ********** 矢印マクロ ************************************************
' *
' * 選択されたセルに赤矢印を作成する。エビデンスや手順書整備用。
' * ショートカットキーを割り当てる想定。
' **********************************************************************
Sub CreateRedArrow()
    
    Dim leftTop, rightBottom As Range
    Dim arrow As shape
    
    ' **************************************
    ' ** 前処理【START】 *******************
    ' **************************************
    
    ' 左上セルの取得
    Set leftTop = activeCell
    
    ' 右上セルの取得（選択範囲のセルを数えLast番目が右下にあたる）
    Set rightBottom = Range(Selection(Selection.Count).Address(False, False))

    
    ' **************************************
    ' ** 赤枠の作成【START】****************
    ' **************************************
    
    ' アローの作成
    Set arrow = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, _
    activeCell.Left, activeCell.Top, rightBottom.Offset(0, 1).Left, rightBottom.Offset(1, 0).Top)
    arrow.Line.EndArrowheadStyle = msoArrowheadTriangle
    
    ' **************************************
    ' ** オブジェクトの見た目調整【START】**
    ' **************************************
    
    ' 枠の設定
    With arrow.Line
        .Visible = msoTrue
        
        ' 枠色の設定
        .ForeColor.RGB = RGB(255, 0, 0)
        
        ' 透過率（0.0が不透明、1.0が透明）
        .Transparency = 0.3
        
        ' 枠の太さ
        .Weight = 3
        
    End With
    
    ' **************************************
    ' ** 後処理【START】 *******************
    ' **************************************

    ' 特になし

End Sub

' ********** 吹き出し作成マクロ ********************************************
' *
' * 選択されたセル吹き出し枠を作成する。エビデンスや手順書整備用。
' * 四角枠（バブル）+線（アロー）の形で作成する。
' * ショートカットキーを割り当てる想定。
' **********************************************************************
Sub CreateFukidashi()
    
    Dim width, height As Integer
    Dim leftTop, rightBottom As Range
    Dim bubble, arrow As shape
    
    ' **************************************
    ' ** 前処理【START】 *******************
    ' **************************************
    
    ' 左上セルの取得
    Set leftTop = activeCell
    
    ' 右上セルの取得（選択範囲のセルを数えLast番目が右下にあたる）
    Set rightBottom = Range(Selection(Selection.Count).Address(False, False))
    
    ' 幅の計算
    width = rightBottom.Offset(0, 1).Left - activeCell.Left
    
    ' 高さの計算
    height = rightBottom.Offset(1, 0).Top - activeCell.Top
    
    ' 左側にアローを作る都合でA列だとバグるので回避。
    If activeCell.Column = 1 Then
        MsgBox "B列以右で実行してください。"
        Exit Sub
        
    End If
    
    ' **************************************
    ' ** 吹き出しの作成【START】************
    ' **************************************
    
    ' バブルの作成
    Set bubble = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, activeCell.Left, activeCell.Top, width, height)
    bubble.Fill.Visible = msoTrue
    
    ' アローの作成（バブルの左にくっつける）
    Set arrow = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, activeCell.Left, activeCell.Top, activeCell.Offset(0, -1).Left, activeCell.Top)
    arrow.ConnectorFormat.BeginConnect bubble, 2
    
    ' グループ化を行なう
    bubble.Select Replace:=False
    arrow.Select Replace:=False
    Selection.ShapeRange.Group.Select
    
    ' **************************************
    ' ** オブジェクトの見た目調整【START】**
    ' **************************************
    
    ' バブル：塗りつぶし設定
    With bubble.Fill
    
        ' 塗りつぶし有
        .Visible = msoTrue
        
        ' 塗りつぶし色の設定
        .ForeColor.RGB = RGB(255, 230, 153)
        
        ' 透過率（0.0が不透明、1.0が透明）
        .Transparency = 0.5

        ' テキトーにグラデーションにする
        .OneColorGradient msoGradientDiagonalDown, 1, 1
        .GradientStops.Insert RGB(255, 230, 153), 0, 0.3
        .GradientStops.Insert RGB(255, 255, 255), 0.85, 0.3
        .GradientStops.Insert RGB(255, 230, 153), 1, 0.3
        .GradientAngle = 225
        
    End With
    
    '  バブル：枠線設定
    With bubble.Line
    
        ' 枠線有
        .Visible = msoTrue
        
        ' 枠色の設定
        .ForeColor.RGB = RGB(255, 217, 102)
        
        ' 枠の太さ
        .Weight = 2
    End With

    ' バブル：フォント設定
    With bubble.TextFrame2.TextRange.Font

        .NameComplexScript = STANDARD_FONT_NAME
        .NameFarEast = STANDARD_FONT_NAME
        .Name = STANDARD_FONT_NAME
        
    End With
    
    ' バブル：フォント色設定
    With bubble.TextFrame2.TextRange.Font.Fill
        .Visible = msoTrue
        .ForeColor.RGB = RGB(0, 0, 0)
        .Transparency = 0
        .Solid
    End With
    
    ' バブル：フォントの配置設定
    With bubble.TextFrame2
        .TextRange.ParagraphFormat.Alignment = msoAlignCenter
        .VerticalAnchor = msoAnchorMiddle
    End With
    

    
    ' アロー：プロパティ変更
    With arrow.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 217, 102)
        .ForeColor.TintAndShade = 0
        .ForeColor.Brightness = 0
        .Transparency = 0
        .Visible = msoTrue
        .Weight = 1.5
    End With
    
        
    ' **************************************
    ' ** 後処理【START】 *******************
    ' **************************************

    ' 特になし

End Sub


' ********** ブック内フォント統一マクロ*********************************
' *
' * ブック内のフォントを統一する
' **********************************************************************
Sub FontUnity()
    
    Dim rc As Variant
    Dim dispStr As String
    Dim TargetSheets As Worksheet
    
    ' **************************************
    ' ** 実行前ダイアログ【START】 *********
    ' **************************************
    
    rc = MsgBox("ブック内のフォントを" & dispStr & "に変更しますか？", _
    vbYesNo + vbQuestion, "フォント一斉置換")
    
    ' MsgBoxでキャンセルされたら中止
    If rc = vbNo Then Exit Sub
    
    ' **************************************
    ' ** 前処理【START】 *******************
    ' **************************************
    
    ' 表示名の設定（ログ出力用）　例：Meiryo UI(11 pt)
    dispStr = STANDARD_FONT_NAME & " (" & STANDARD_FONT_SIZE & " pt)"
    
    ' **************************************
    ' ** フォント統一処理【START】 *********
    ' **************************************
    
    ' 画面更新をOFF
    Application.ScreenUpdating = False
    
   
    ' シートの数だけループ
    For Each TargetSheets In Worksheets
   
        ' フォントおよびサイズを設定する
        With TargetSheets.Cells.Font

            .Name = STANDARD_FONT_NAME
            .Size = STANDARD_FONT_SIZE

       End With
       
   Next TargetSheets
   
    '画面更新を再開
    Application.ScreenUpdating = True
    
    ' **************************************
    ' ** 後処理【START】 *******************
    ' **************************************
    
    ' 完了メッセージを表示
    MsgBox "全てのフォントを" & dispStr & "に設定しました。"
   
End Sub

' ********** 標準フォント上書きマクロ *********************************
' *
' * 標準フォントを上書きする。
' **********************************************************************
Sub SetStandardFont()

    ' **************************************
    ' ** 標準フォント設定【START】 *********
    ' **************************************
    
    ' 標準フォントの設定
    Application.StandardFont = STANDARD_FONT_NAME
    Application.StandardFontSize = STANDARD_FONT_SIZE

End Sub

マクロ内のショートカットキーはお好みで設定（変更）してください。
また、マクロをクイックアクセスツールバーに登録しても良いです。

[3] 自動起動設定

これまでの手順ですでにマクロを使用することはできるのですが、
Excelアプリケーションをすべて閉じるとショートカットキー登録を忘れてしまいます。
そこで、Excelを起動するたびにショートカット登録関数だけ自動起動するようにします。
　1. VBAProject(PERSONAL.XLSB）内に初期から存在する「ThisWorkbook」を開く
　2. 以下のソースをコピー＆ペーストする

(B) ThisWorkbook（PERSONAL.XLSB）
PERSONAL.XLSB（ThisWorkbook）
' ***Workbook_Open*********************************************************
' * Excelファイル起動時に自動実行されるマクロ。
' * ショートカットキーの登録などを行なう。
' * このマクロだけは「ThisWorkbook」に記述しないと自動実行されない。
' *************************************************************************
Private Sub Workbook_Open()
    
    ' ショートカットキーの割り当て
    AssignShortcutKey
    
End Sub

Excel起動時にショートカットキーの割当を行ないます。
貼付先は「ThisWorkbook」です。お間違いのないように。

[4] Excelの再起動

一度Excelをすべて閉じてください。
（個人マクロの保存が問われるので保存してください。）

おわりに

いかがでしたでしょうか。
ぜひ活用していただければ嬉しいです。

また気が向いたらマクロを追加／更新したいと思います。

9
13
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
9
13

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?