ゆるおたノート

Tomorrow is another day.

トップ > ■プログラム全般 > 【随時編集】VBAリファレンス集

【随時編集】VBAリファレンス集

■プログラム全般 VBA VBA-逆引きリファレンス

VBAコードと参考サイトの自分用リファレンス。随時、追加・修正していきます。*1

なお、コードは等幅フォントを前提にインデントしています。
それ以外は結構レイアウトが崩れるので要注意です。。。

また、うっかり人間なので内容や参照元に抜け・誤りがあるかもしれません。
申し訳ありません。。。
その際は、コメントなどでご指摘いただけますと幸いです。

宣言セクション

行・列の命名

表記ゆれ、構文エラーの防止に。

タスク管理向け
Enum ●●Rows
    Button =1
    Index
    InputData
End Enum
'↑列と表記を統一して、変数と区別するのに有効

'↓こっちの方が文字数は減る（スッキリ）
'Const BUTTON_ROW = 1
'Const INDEX_ROW = 2
'Const INPUT_ROW = 3

Enum ●●Cols
    ReferenceNum = 1
    MyStatus
    ToDo
    MyPriority
    Memo '備忘録やメモを残す部分
    TeamPriority
    TeamStatus
    Age
    Waiting
    DueDate
    LastUpdateDate
    CreateDate
End Enum
文字列の操作向け
Enum ●●Cols
    Index = 1
    InputData
    Output1
    Output2
    ' つづく…
End Enum

Const INDEX_ROW = 2
Const INPUT_ROW = 3

マクロを使いやすくする

高速化の基本魔法。

いろいろ止めます。

プロシージャ1つ Ver.
Public Sub improveMacroPerformance()

    '▼準備
    '画面の再描画/自動計算/イベント受付を停止
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    '▼実際の処理
    Call ●MainProceedure●

    '▼後処理
    '→すべて終わったら戻ってくる
    '画面の再描画/自動計算/イベント受付を再開
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .EnableEvents = True
    End With

End Sub
プロシージャ分解 Ver.

1つのモジュールに複数プロシージャを作成すると煩雑になるので、先頭と末尾に分けて各プロシージャからの呼び出し形式に。

  • ▼使用例

    • 1枚のワークシートにボタンをいくつか作るとき
    • プロシージャを部品化して長い処理をするとき
'▼実際の処理
Sub メインプロシージャ

    Call startPerformanceImprovement

    処理内容①
    処理内容②
    処理内容③

    Call finishPerformanceImprovement

End Sub

Private Sub startPerformanceImprovement()

    '画面の再描画/自動計算/イベント受付を停止
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

End Sub

Private Sub finishPerformanceImprovement()
'作成後、エラーとかでマクロが止まった時に自動計算等を元に戻せるよう、
'"Public"で外から呼び出し可にしておく。

    '画面の再描画/自動計算/イベント受付を再開
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .EnableEvents = True
    End With

End Sub

実行時間の計測

プロシージャ1つ Ver.
Public Sub ●プロシージャ名●()

    '▼計測スタート
    Dim startTime As Variant
    startTime = Time

    '▼実際の処理
    Call ●MainSub●

    '▼計測ストップ
    Dim finishTime As Variant
    finishTime = Time

    MsgBox "取得が完了しました" & vbLf _
         & "実行時間は" & Format(finishTime - startTime, "nn分ss秒") & "でした"

End Sub
プロシージャ分解 Ver.

計測中は変数startTimeを渡して行かなきゃいけないので、Mainモジュール等を作って変数を操作しやすいマクロの作成をオススメします。

'▼実際の処理
Sub メインプロシージャ

    Dim startTime As Variant
    startTime = startCountSpeed

    処理内容①
    処理内容②
    処理内容③

    Call finishCountSpeed(startTime)

End Sub

Private Function startCountSpeed()

    startCountSpeed = Time '現在時刻

End Function

Private Sub finishCountSpeed(ByVal startTime As Variant)

    Dim finishTime As Variant
    finishTime = Time '現在時刻

    MsgBox "取得が完了しました" & vbLf _
         & "実行時間は" & Format(finishTime - startTime, "nn分ss秒") & "でした"

End Sub

定位置に戻す

処理が終わったら、定位置に戻します。

カーソル位置
Public Sub CursorMovesTo(ByRef startPosition As Range)

    '▼前処理
    '念のため画面描画を再開しておく
    '※画面描画が止まっているとカーソルだけ移動してウィンドウ位置はそのままになってしまうため。
    Application.ScreenUpdating = True

    '一旦シートをアクティベートしておく
    '※「セル.Select」のエラー防止のため。
    startPosition.Parent.Activate

    '▼メイン
    With startPosition
        '空欄なら[Ctrl]+[↓]方向に移動しておく
        If .value = "" Then Set startPosition = .End(xlDown)
    End With

    'Withの外側で改めて選択
    '※Withブロックで選択されている'startPosition自体は、
    '「ブロック内で再代入が実行されても再代入前の値のまま」で選択先が変更にならないので…
    startPosition.Select

    '▼後処理
    '元に戻しておく（元がTrueの場合は分岐しないと…）
    Application.ScreenUpdating = False

End Sub
スクロール
'画面描画が有効な状態で使う
Sub setWindowPosition()

    '所定のセルをアクティブにしておく（省略可）
    Cells(1, 1).Select

    '画面をスクロールする
    With ActiveWindow
        .ScrollColumn = 1
        .ScrollRow = 1
    End With

End Sub

ファイルの操作

ファイルの場所や名前を取得

ファイル名はGetOpenFileNameメソッドで取得。

Sub GetOpenFileName()

    '選択したファイルを（開かずに）ファイル名のみ取得
    Dim selectionFilePath As String
    selectionFilePath = Application.GetOpenFileName
    If selectionFilePath = "False" Then Exit Sub '選択しなければモジュールを終了

    'ファイル名（拡張子つき）
    Dim fileNameWithExtesion As String
    fileNameWithExtesion = Dir(selectionFilePath)

    '最後に「\」つきのパス
    Dim folderPathWithDelimiter As String
    folderPathWithDelimiter = Left(selectionFilePath, _
                                   Len(selectionFilePath) - Len(fileNameWithExtesion))

    'ファイル名（拡張子なし）
    Dim fileName As String
    If InStr(fileNameWithExtesion, ".") = 0 Then
        fileName = fileNameWithExtesion
    Else
        fileName = Left(fileNameWithExtesion, _
                        InStr(fileNameWithExtesion, ".") - 1)
    End If

    MsgBox "=========================================" & vbCr & _
           "[選択されたファイルのフルパス]" & vbCr & _
           selectionFilePath & vbCr & _
           vbCr & _
           "[フォルダの場所]" & vbCr & _
           folderPathWithDelimiter & vbCr & _
           vbCr & _
           "ファイル名（拡張子つき）：" & fileNameWithExtesion & vbCr & _
           "ファイル名（拡張子なし）：" & fileName & vbCr & _
           "========================================="
           'Excel95ではvbCrに替えてChr(13)を使用

End Sub

パスをDictionaryオブジェクトに格納

Private Function setWorkbookPaths()

    Dim pathDic As New Dictionary
    With pathDic
        '.Add ファイル名, フルパス
        .Add "ddd.xlsm", "C:aaa\bbb\ccc\ddd.xlsm"
        .Add "hhh.xlsm", "C:eee\fff\ggg\hhh.xlsm"
    End With

    Dim i As Long
    '添え字は0始まり
    For i = 0 To pathDic.Count - 1
        '【例】=================================================
        Debug.Print "パス：" & pathDic.Keys(i) & vbCrLf & _
                    "ファイル名：" & pathDic.Items(i)
        '=====================================================
    Next i

    Set storeWbNames = pathDic

End Function

ワークブックの操作

ブックを開く

Private Sub openWorkbooks(ByRef targetPathDic As Dictionary)

    Dim i As Long
    For i = 0 To targetPathDic.Count - 1
        '処理に必要なワークブックが開いてなければ開く
        Dim wbPath As String
        wbPath = targetPathDic.Items(i)

        If canOpen(wbPath) = True Then
            openWithParamShift (wbPath)
        End If
    Next i

End Sub

Private Sub openWithParamShift(ByRef targetWorkbookPath As String)

    If InStr(targetWorkbookPath, ".xltx") > 0 Then
       Workbooks.Open Filename:=targetWorkbookPath, _
                                   editable:=True
    Else
       Workbooks.Open Filename:=targetWorkbookPath, _
                                   ReadOnly:=True, _
                                   Password:="●●" 'もしパスワードがあったら入力
    End If

End Sub

状態チェック

Private Function canOpen(ByVal wbPath As String) As Boolean

    Dim ret As Boolean
    ret = False

    Dim arrSplitPath As Variant
    Dim wbName As String
    arrSplitPath = Split(wbPath, "\")
    wbName = arrSplitPath(UBound(arrSplitPath))

    If isExistWb(wbPath, wbName) = True _
           And isWbClose(wbName) = True Then
        ret = True
    End If

    canOpen = ret

End Function

'--------------------------------------------------------
'●マクロ作成時：事前バインディング
'※あらかじめ【Microsoft Scripting Runtime】を参照設定しておく。
'    Dim Fso As New Scripting.FileSystemObject

'●マクロ配布時：実行時バインディング
'    Dim Fso As Object
'    Set Fso = CreateObject("Scripting.FileSystemObject")
'--------------------------------------------------------
Private Function isExistWb(ByVal targetWorkbookPath As String, _
                           ByVal targetWorkbookName As String)

    Dim ret As Boolean
    ret = True

'マクロ作成時用
    Dim Fso As New Scripting.FileSystemObject

'マクロ配布用
'    Dim Fso As Object
'    Set Fso = CreateObject("Scripting.FileSystemObject")

    If Not Fso.FileExists(targetWorkbookPath) Then
        MsgBox "『" & targetWorkbookName & "』は存在しません。" & vbCrLf _
             & "名前を変えましたか？", vbExclamation
        ret = False
    End If

    isExistWb = ret

End Function

Private Function isWbClose(ByVal targetWorkbookName As String) As Boolean

    Dim ret As Boolean
    ret = True '初期化

    'ブックを開いているかチェック
    Dim tmpWorkbook As workbook
    For Each tmpWorkbook In Workbooks
        If tmpWorkbook.Name = targetWorkbookName Then
            MsgBox "『" & targetWorkbookName & "』は既に開いているので飛ばします。"
            ret = False
        End If
    Next tmpWorkbook

    isWbClose = ret

End Function

ブックの保存

作業中のブックを保存して格納

マクロブックと同じ階層に、生データフォルダと格納先フォルダがあると想定。

  • マクロブック
  • 生データフォルダ
  • 格納先フォルダ
Dim bookName As String
'フォルダ内のブック名を1つ取得して変数に格納しておく
bookName = Dir(ThisWorkbook.Path & "\生データフォルダ\*")

'作業ファイルを上書き保存で一旦閉じて、格納先フォルダに移動
ActiveWorkbook.Close savechanges:=True
Name ThisWorkbook.Path & "\生データフォルダ\*" & bookName _
  As ThisWorkbook.Path & "\格納先フォルダ\*" & bookName
月ごとのフォルダに分類して保存
Private Sub saveAsTodayResults(ByVal targetWorkbookPath As String)

    'フォルダの指定
    Dim pathSaveDir As String
    pathSaveDir = ThisWorkbook.Path & "\履歴\" & Format(Date, "yyyymm")

    '「履歴」フォルダがなかったら作成する
    Dim tmpFso As New FileSystemObject
    If tmpFso.FolderExists(pathSaveDir) = False Then
        MkDir (pathSaveDir)
    End If

    'ファイル名の指定
    Const TEMPLATE_NAME As String = "●●.xlsx" '拡張子付きで指定すること。
    Dim newPath As String
    newPath = pathSaveDir & "\" & Format(Date, "yyyymmdd") & TEMPLATE_NAME

    'テンプレートを開く
    Dim wbFormat As Workbook
    Set wbFormat = Workbooks.Open(Filename:=targetWorkbookPath, _
                                  editable:=False) 'テンプレート自体は編集しない（省略可）

    '指定したファイル名で保存する
    wbFormat.SaveAs (newPath)

End Sub

フォントを指定

Meiryo UIが好きです。

Sub setFont()

    Dim strFontName As String: strFontName = "Meiryo UI"
    Dim numFontSize As Long: numFontSize = 9

    'Excelアプリケーションの標準フォントを変更
    With Application
        .standardFont = strFontName
        .standardFontSize = numFontSize
    End With

    '各シートのフォントを変更
    Dim ws As Worksheet
    For Each ws In Worksheets
        With ws.Cells.Font
            .Name = strFontName
            .Size = numFontSize
        End With
    Next ws

    'メッセージボックスを作成
    Dim msg As String
    Dim strFontSize As String: strFontSize = CStr(numFontSize) '数値を文字列化

    msg = "設定を変更しました。"
    msg = msg & vbCrLf & "----------------------------"
    msg = msg & vbCrLf & "▼Excelアプリケーション"
    msg = msg & vbCrLf & "フォント：" & strFontName
    msg = msg & vbCrLf & "サイズ：" & strFontSize & " px"
    msg = msg & vbCrLf & "（ダウンロードしたファイルには反映されません。）"
    msg = msg & vbCrLf & "----------------------------"
    msg = msg & vbCrLf & "▼ワークシート"
    msg = msg & vbCrLf & "フォント：" & strFontName
    msg = msg & vbCrLf & "----------------------------"

    'メッセージボックスを出力
    MsgBox msg
    MsgBox "設定反映のため、1度Excelを再起動してください。"

End Sub

ワークシートの操作

シートをコピーする

新規ブックに作成
Worksheets("ひな形").Copy
同じブック内で作成
'ブック内の最後尾に作成する
Worksheets("ひな形").Copy after:=Worksheets(Worksheets.Count)

'ブック内の先頭に作成する
Worksheets("ひな形").Copy before:=Worksheets(Worksheets.Count)
シート名を変更して指定位置に作成
Worksheets("ひな形").Copy After:=Worksheets("左隣にするシート")
ActiveSheet.Name = "新しいシート名"

シートの移動

名前を変更して移動
With Worksheets("動かすシート")
    .Move After:=Worksheets("左隣にするシート")
    .Name = "新しいシート名"
End With

シートを削除する

Application.DisplayAlerts = False 'いったん警告を消す
Worksheets("data").Delete
Application.DisplayAlerts = True '元に戻す

表の操作

データの転記

値のみ貼り付け

コピー元・コピー先で始点と終点のセルをそれぞれ確認して、値の貼り付けをします。

Public Sub copyToFormat(ByRef copySheet As Worksheet, _
                        ByRef pasteSheet As Worksheet)

    Dim upperLeftCopyCell As Range
    Set upperLeftCopyCell = copySheet.Cells(1, 1)

    Dim upperRightCopyCell As Range
    Set upperRightCopyCell = upperLeftCopyCell.End(xlToRight)

    '表の右端行数を取得
    Dim copyColsNum As Long
    copyColsNum = copySheet.Range(upperLeftCopyCell, _
                                  upperRightCopyCell).Columns.Count

    '表の最終行を取得
    Dim lastCell As Range
    Dim lastRowNum As Long
    Set lastCell = copySheet.Cells(copySheet.Rows.Count, 1) '空行の無い列を指定する
    lastRowNum = lastCell.End(xlUp).Row

    Const INDEX_ROW As Long = 1
    Dim upperLeftPasteCell As Range
    Dim lowerRightPasteCell As Range
    Set upperLeftPasteCell = pasteSheet.Cells(INDEX_ROW + 1, 1)
    Set lowerRightPasteCell = pasteSheet.Cells(INDEX_ROW + lastRowNum, _
                                               copyColsNum)

    Dim lowerRightCopyCell As Range
    Set lowerRightCopyCell = copySheet.Cells(lastRowNum, copyColsNum)

    '値のみ貼り付け
    pasteSheet.Range(upperLeftPasteCell, lowerRightPasteCell).Value _
    = copySheet.Range(upperLeftCopyCell, lowerRightCopyCell).Value

End Sub

データの抽出

オートフィルタを使って抽出します

Range("●●:●●").AutoFilter

'抽出条件：絞り込みたいもの
'（複数ある時は 配列（Array(a,b,c,...) で指定する）
ActiveSheet.Range("●●:●●").AutoFilter Field:=●●, _
                                         Criteria1:=●抽出条件●, _
                                         Operator:=xlFilterValues

'フィルタオフ
ActiveSheet.AutoFilterMode = False
不要な行を削除
Sub オートフィルタして削除
    With Range("A1").CurrentRegion
        .AutoFilter field:=4, _
                    Criterial:="B", _
                    Operator:=xlFilterValues '1.

        .Offset(1,0).EntireRow.Delete '2.
        .AutoFilter '3.
    End With
End Sub

  • ▼処理の流れ

    1. データ範囲の4列目からBを抽出
    2. データ範囲の項目行（1行目）以外を選択して削除
    3. オートフィルタがかかっている状態で引き数なしでAutoFilterメソッドを実行すると、フィルタが解除される。

  • ▼参考にさせていただきました！

    たった1秒で仕事が片づく Excel自動化の教科書

    たった1秒で仕事が片づく Excel自動化の教科書

    • 作者:吉田 拳
    • 発売日: 2016/06/08
    • メディア: 単行本（ソフトカバー）

ソート

基本

キーとオーダー（並び順）はいくつでも増やせるとのこと。

Sub Macro1()
　　With ThisBook.Sheet1.Sort
　　　　.SortFields.Clear 'いったん初期化

　　　　.SortFields.Add Key:=Range("A1"), Order:=xlAscending
　　　　.SortFields.Add Key:=Range("B1"), Order:=xlDescending
　　　　.SortFields.Add Key:=Range("C1"), CustomOrder:="開始,終了,回答待ち,保留"
　　　　.SetRange Range("A1:J11")
　　　　.Header = xlYes '=1行目はデータではない

　　　　.Apply '実行
　　End With

End Sub
まとめてソート
Sub Main()

    Const LIST_NAME = "テーブル名"
    Dim targetList As ListObject
    set targetList = ThisWorkbook.Worksheets(1).ListObjects(LIST_NAME)

    'ソート順を定義（重複防止のためにDictionary型を使用）
    Dim sortDic As New Dictionary
    With sortDic
        '.Add 列番号, 昇順/降順
        .Add 列番号1, xlAscending
        .Add 列番号2, xlDescending
        .Add 列番号3, xlAscending
        .Add 列番号4, xlDescending
        .Add 列番号5, xlAscending
        .Add 列番号6, xlDescending
        ' つづく…
    End With

    Call SortAs(sortDic, targetList)

End Function

''
' テーブルを任意の順にソート
'
' @param {Dictionary} [Key:列番号, Item:昇順/降順]の辞書
' @param {object} ソートするテーブル
' @param {Long} テーブルの開始列（Cells(1, 1)ではない場合）
'
Public Sub SortAs(ByRef orderDefinitions As Dictionary, _
                  ByRef listObj As ListObject, _
                  Optional ByVal listStartCol As Long = 0)

    With listObj

        Dim i As Long
        For i = 0 To orderDefinitions.Count - 1

            ' リストの見出し部分のデータを取り出します | Excel VBA 表計算とプログラミング教室
            ' https://atelierkobato.com/header/
            Dim sortKeyCell As Range
            Set sortKeyCell = .HeaderRowRange.Cells(1, orderDefinitions.Keys(i) - listStartCol)

            With .sort
                .SortFields.Clear
                .SortFields.Add2 Key:=sortKeyCell, _
                                 SortOn:=xlSortOnValues, _
                                 Order:=orderDefinitions.Items(i), _
                                 DataOption:=xlSortNormal
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With

            '例）列 1or0 セルの値
'            Debug.Print Format(orderDefinitions.Keys(i), "#,#00"); orderDefinitions.Items(i); .HeaderRowRange.Cells(1, orderDefinitions.Keys(i) - listStartCol)

        Next
    End With

End Sub

表の装飾

「条件付き書式」を使います。

無限増殖対策。

コピペの繰り返しで条件式が無限に増えていく。。。
これ結構厄介ですよね。

今のところ無限増殖を止める方法は無いらしいので、都度全消去して改めて設定し直します。

'いったんすべて消す
Cells.FormatConditions.Delete

私は、表の転記やソート等の日々使うマクロへついでに入れておいて、都度まとめて処理してもらっています。

シンプルに条件付き書式を設定。

シンプルisベスト。（解説がわかりやすい…）

Sub Macro1()
    Dim myCond As FormatCondition
    With Range("A1")
        .FormatConditions.Delete
        Set myCond = .FormatConditions.Add(Type:=xlCellValue, _
                                           Operator:=xlLessEqual, _
                                           Formula1:="30")
        myCond.Font.ColorIndex = 3
        Set myCond = .FormatConditions.Add(Type:=xlCellValue, _
                                           Operator:=xlLessEqual, _
                                           Formula1:="50")
        myCond.Font.ColorIndex = 6
    End With
End Sub
値で色分け
割り振りを強調。

割り振り表に自分の名前があったら強調表示。

'「Colmuns(eTable.Assigned)」に条件付き書式を設定
With Columns(eTable.Assigned)
    '前準備（いったん指定範囲のフォントをグレーに変更しておく）
    With .Font
       .ColorIndex = 15 'グレー
        .Bold = False
    End With

    '私の名前があったら...
    Dim myNAME As String
    myNAME = ●私の名前●
    .FormatConditions.Add Type:=xlTextString, _
                          String:=myNAME, _
                          TextOperator:=xlContains

    'この条件付き書式を指定範囲の最優先に設定する
    .FormatConditions(Columns(eTable.Assigned) _
                      .FormatConditions.Count).SetFirstPriority

    '条件に当てはまる場合の書式を指定
    With .FormatConditions(1)
        With .Font
            .Bold = True
            .Color = -11489280
        End With

        .Interior.Color = RGB(169, 208, 142) '淡い緑

        '下位の条件付き書式も反映可
        .StopIfTrue = False
    End With

End With
汎用化ver.
  • ▼作成する条件式
    =OR($A1="keyWord1",$A1="keyWord2",$A1="keyWord3",…)
''
' 指定列に値があったら行ごと色付けする
'
' @param {array} 条件に使う値の配列
' @param {object} この条件付き書式を設定する範囲
' @param {long} 検索する列（指定範囲内の番号）
' @param {long} 条件を満たしたときの行の背景色（既定：淡いグレー）
' @param {long} 条件を満たしたときのフォントの色（既定：濃いグレー）
' @param {long} 条件を満たしたときに斜体にするか
'
Public Sub setRowColors(ByRef searchValues As Variant, _
                        ByRef coloringRange As Range, _
                        Optional ByVal searchColNumber As Long = 1, _
                        Optional ByVal interiorColor As Long = 14277081, _
                        Optional ByVal fontColor As Long = 10921638, _
                        Optional ByVal isItalic As Long = True)

    Dim keyCell As Range
    Set keyCell = coloringRange.Cells(1, searchColNumber)

    Dim targetExpression As String
    targetExpression = joinFormulas(keyCell, searchValues)

    With coloringRange
        ' 条件付き書式を追加
        .FormatConditions.Add Type:=xlExpression, _
                              Formula1:=targetExpression
        ' 第1位にセット
        .FormatConditions(.FormatConditions.Count).SetFirstPriority

        Const FIRST As Long = 1
        With .FormatConditions(FIRST)

            With .Font
                .Italic = isItalic
                .Color = fontColor
            End With

            .Interior.Color = interiorColor

            ' '下位の条件付き書式も反映可
            .StopIfTrue = False
        End With
    End With

End Sub

Private Function joinFormulas(ByRef keyCell As Range, _
                              ByRef keyWords As Variant) As String

    ' 戻り値
    Dim retExpression As String: retExpression = "" ' 初期化

    ' 引数分繰り返す
    Dim iParam As Long
    Dim paramCounts As Long: paramCounts = UBound(keyWords)
    For iParam = 0 To paramCounts
        Dim colAddress As String
        colAddress = keyCell.Address(RowAbsolute:=False, _
                                  ColumnAbsolute:=True)

        Dim keyWord As String
        If VarType(keyWords(iParam)) = vbString Then
            Const DOUBLE_QUATATION As String = """"
            keyWord = DOUBLE_QUATATION & keyWords(iParam) & DOUBLE_QUATATION

        Else
            keyWord = keyWords(iParam)

        End If

        Dim temp As String
        temp = ""
        temp = colAddress & "=" & keyWord

        Select Case iParam
            Case 0
                retExpression = temp
                ' 要素が1つだけならここで終わり
                If (paramCounts = 0) Then Exit For

            Case Is < paramCounts
                retExpression = retExpression & "," & temp

            ' 最後ならカッコを閉じて終了
            Case paramCounts
                retExpression = "OR(" & retExpression & "," & temp & ")"
        End Select
    Next

    retExpression = "=" & retExpression

    joinFormulas = retExpression

End Function
罫線

カテゴリ別など、値の区切りで罫線を引きます。

  • ▼作成する条件式
    =$A1<>$A2
''
' 値が変化するところで横方向に罫線を引く
'
' @param {object} この条件付き書式を設定する範囲
' @param {Long} 罫線の基準とする列番号（指定範囲のうちで何列目？）
' @param {Long} 罫線の色
' @param {Long} 罫線の位置
' @param {Long} 罫線のスタイル
' @param {Long} 罫線の太さ
'
Public Sub drawRowBorder(ByRef drawingRange As Range, _
                         Optional ByVal criteriaColNumber As Long = 1, _
                         Optional ByVal lineColor As Long = 0, _
                         Optional ByVal linePositionConstant As Long = xlBottom, _
                         Optional ByVal lineStyleConstant As Long = xlContinuous, _
                         Optional ByVal lineWeightConstant As Long = xlThin)

    With drawingRange
        Dim upperAddress As String
        upperAddress = _
            .Cells(1, criteriaColNumber).Address(RowAbsolute:=False, _
                                                 ColumnAbsolute:=True)
        Dim lowerAddress As String
        lowerAddress = _
            .Cells(2, criteriaColNumber).Address(RowAbsolute:=False, _
                                                 ColumnAbsolute:=True)
    End With

    Dim targetExpression As String
    targetExpression = "=" & upperAddress & "<>" & lowerAddress

    With drawingRange
        ' 条件付き書式を追加
        .FormatConditions.Add Type:=xlExpression, _
                              Formula1:=targetExpression
        ' 第1位にセット
        .FormatConditions(.FormatConditions.Count).SetFirstPriority

        Const FIRST As Long = 1
        With .FormatConditions(FIRST)
            With .Borders(linePositionConstant)
                .LineStyle = xlContinuous
                .Weight = lineWeightConstant
                .Color = lineColor
            End With

        ' '下位の条件付き書式も反映可
        .StopIfTrue = False

        End With
    End With

End Sub

チェックシートの作成

条件付き書式による表の装飾を応用して、チェックシートを作成します。

その1 - 基本

A列にd（＝完了（done））と記入されたら、その行に色を付ける。

  • ▼作成する条件式
    =$A1="keyWord"
'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
'※必ず、直前で書式を設定する範囲列を指定しておく
'Dim targetColumns As Variant
'Set targetColumns = Range(Columns(eTable.●はじめ列●), Columns(eTable.●おわり列●))
'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Private Sub setCheckSheet_BASIC()

    Dim keyCol  As String
    Dim keyWord As String
    Dim conditionalExpression As String
    'keyColを'$ & rows(行) & eTable.●Input列●' で指定できないか研究したい…
    keyCol  = "$A1"
    keyWord = "d"
    conditionalExpression = "=" & keyCol & "=" & """" & keyWord & """"

    With targetColumns
        .FormatConditions.Add Type:=xlExpression, _
                              Formula1:=conditionalExpression

        '指定した範囲で条件付き書式の最優先に設定
        .FormatConditions(targetColumns.FormatConditions.Count).SetFirstPriority

        With .FormatConditions(1)
            '行の色をRGB関数で指定
            .Interior.Color = RGB(169, 208, 142) '淡い緑
            '下位の条件付き書式も反映可
            .StopIfTrue = False
        End With
    End With

End Sub
その2 - 表記ゆれ対応Ver.

私がよく使うのはこちらです。

  • ▼作成する条件式
    =OR($A1="keyWord1",$A1="keyWord2")
'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
'※必ず、直前で書式を設定する範囲列を指定しておく
'Dim targetColumns As Variant
'Set targetColumns = Range(Columns(eTable.●はじめ列●), Columns(eTable.●おわり列●))
'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Private Sub setCheckSheet_OR()

    Dim keyCol As String
    Dim keyWord1 As String
    Dim keyWord2 As String
    keyCol = "$A1"
    keyWord1 = "d" '半角
    keyWord2 = "ｄ" '全角

    Dim conditionalExpression As String
    conditionalExpression = "=OR(" & keyCol & "=" & """" & keyWord1 & """" & "," _
                                   & keyCol & "=" & """" & keyWord2 & """" & ")"

    With targetColumns
        .FormatConditions.Add Type:=xlExpression, _
                              Formula1:=conditionalExpression

        '指定した範囲で条件付き書式の最優先に設定
        .FormatConditions(targetColumns.FormatConditions.Count).SetFirstPriority

        With .FormatConditions(1)
            '行の色をRGB関数で指定
            .Interior.Color = RGB(169, 208, 142) '淡い緑
            '下位の条件付き書式も反映可
            .StopIfTrue = False
        End With

    End With

End Sub

テーブルの操作

データを全削除

入力したデータを削除して、入力位置にメッセージをつけます。

Sub deleteListRows()

    Const LIST_NAME As String = "xxxxxxxx"
    Dim i As Long
    With ActiveSheet.ListObjects(LIST_NAME).ListRows
        For i = .Count To 1 Step -1 '下から順次削除
            .Item(i).Delete
        Next i
    End With

    Const INPUT_ROW =3
    Cell(INPUT_ROW,1).Value = "ここに値のみ貼り付け"

    MsgBox "データの削除が完了しました。"

End Sub

データの整形

箇条書きを表にする

ちょっと長いんですが…

Option Explicit

'列名を指定しておく
Enum eCol
  Inputs = 1
  Output1
  Output2
End Enum

Sub SplitOverviewStrings()

    '※A2に文字列をペーストして、順に下のセルへ文字列が入力されている場合
    Const INPUT_ROW As Long = 2
    Cells(INPUT_ROW, eCol.Inputs).Select

    Dim targetSheet As Worksheet
    Set targetSheet = ThisWorkbook.ActiveSheet

    '不要であれば消してok
    With targetSheet.Cells
        .NumberFormatLocal = "@"
        .Font.Name = "Meiryo UI"
        .Font.Size = 10
    End With

    Dim i As Long
    Dim lastRow As Long
    i = targetSheet.UsedRange.Rows.Count
    lastRow = targetSheet.UsedRange.Rows(i).Row

    Dim r As Long
    For r = 2 To lastRow

        Dim ThisStr As String
        ThisStr = Cells(r, eCol.Inputs).Value
        Dim splitedStrings As Variant

        '"：　"（全角コロン＋全角スペース）
        If InStr(1, ThisStr, "：　") <> 0 Then
            splitedStrings = Split(ThisStr, "：　")
            Call outputStrings(splitedStrings, r)

        '"： "（全角＋半角）
        ElseIf InStr(1, ThisStr, "： ") <> 0 Then
            splitedStrings = Split(ThisStr, "： ")
            Call outputStrings(splitedStrings, r)

        '"："（全角）
        ElseIf InStr(1, ThisStr, "：") <> 0 Then
            splitedStrings = Split(ThisStr, "：")
            Call outputStrings(splitedStrings, r)

        '":　"（半角＋全角）
        ElseIf InStr(1, ThisStr, ":　") <> 0 Then
            splitedStrings = Split(ThisStr, ":　")
            Call outputStrings(splitedStrings, r)

        '": "（半角＋半角）
        ElseIf InStr(1, ThisStr, ": ") <> 0 Then
            splitedStrings = Split(ThisStr, ": ")
            Call outputStrings(splitedStrings, r)

        '":"（半角）
        ElseIf InStr(1, ThisStr, ":") <> 0 Then
            splitedStrings = Split(ThisStr, ":")
            Call outputStrings(splitedStrings, r)

        ElseIf ThisStr = "" Then

        End If

    Next r

    '後処理
    Columns(eCol.Output1).AutoFit
    Columns(eCol.Output2).ColumnWidth = 12#
    Range(Columns(eCol.Output1), Columns(eCol.Output2)) _
        .HorizontalAlignment = xlLeft

End Sub

Sub outputStrings(ByVal splitedStrings As Variant, _
                  ByVal currentRow As Long)

    Dim outputCounts As Long
    Dim splitedCounts As Long

    '取得した配列数（文字列を区切った数）分、Output列へ順に出力
    '※UBound(0)が配列の1つ目※
    For splitedCounts = 0 To UBound(splitedStrings)
        outputCounts = eCol.Output1 + splitedCounts
        Cells(currentRow, outputCounts) = splitedStrings(splitedCounts)
    Next

End Sub
書き直しに挑戦（→更新停止中…）

リーダブルコードへの旅 ～箇条書きを表にする①～ - ゆるおたノート

［おまけ］Excelで遊ぶ

方眼紙の作成（笑）

完全に悪ふざけと思って載せましたが、メモや作図に方眼が欲しいことがありまして、意外と使っています。

Sub Excel方眼紙_笑()

    Dim targetSheet As Worksheet
    'マクロを収録していないブックに登録して使うと想定して、
    '「ThisWorkbook」ではなく「ActiveWorkbook」
    Set targetSheet = ActiveWorkbook.ActiveSheet

    With targetSheet
        .Columns.ColumnWidth = 1.63
        .Rows.RowHeight = 14.25 'ちょっとだけ縦長
        With .Cells
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlBottom
            .IndentLevel = 0
        End With

        '後処理
        .Cells(1, 1).Select
    End With

    MsgBox "Excel方眼紙を作成しました。"

End Sub

注釈

*1:機会があれば、自分でいじった部分は解説記事も作…れる、かなぁ…