ゆるおたノート

Tomorrow is another day.

【随時編集】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

マクロを使いやすくする

高速化の基本魔法。

いろいろ止めます。

▼参考にさせていただきました!
tonari-it.com

プロシージャ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

実行時間の計測

▼参考にさせていただきました!
tonari-it.com

プロシージャ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

ファイルの操作

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

▼参考にさせて頂きました!
www.moug.net

ファイル名は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オブジェクトに格納

【使い方】
コーディング時は、入力補完を使いたいので事前バインディングする。
VBEでMicrosoft Scripting Runtimeを参照設定しておく。

  1. ツール
  2. 参照設定
  3. Microsoft Scripting Runtime」にチェック
  4. OK

配布する時は、実行時バインディングに変更しておくと安全。

▼参考にさせて頂きました! excel-ubara.com

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

状態チェック

▼参考にさせていただきました!
officetanaka.net

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

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

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

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

月ごとのフォルダに分類して保存
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が好きです。

▼解説してみました!
yuru-wota.hateblo.jp

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 = "新しいシート名"

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

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

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

▼参考にさせていただきました!
blog.livedoor.jp

シートの移動

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

▼参考にさせていただきました!
blog.livedoor.jp

シートを削除する

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

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

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

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

表の操作

データの転記

値のみ貼り付け

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

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
不要な行を削除
  1. データ範囲の4列目からBを抽出
  2. データ範囲の項目行(1行目)以外を選択して削除
  3. オートフィルタがかかっている状態で引き数なしでAutoFilterメソッドを実行すると、フィルタが解除される。
Sub オートフィルタして削除
    With Range("A1").CurrentRegion
        .AutoFilter field:=4, _
                    Criterial:="B" '1.
                    Operator:=xlFilterValues

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

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

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

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

ソート

基本

▼参考にさせて頂きました!
detail.chiebukuro.yahoo.co.jp

参考というかまるっとコピペですごめんなさい…

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

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

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

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

▼参考にさせて頂きました!
excel-ubara.com

シンプル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 = "d" '全角

    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

テーブルの操作

データを全削除

▼参考にさせて頂きました!
www.relief.jp

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

Sub deleteListRows()

  Const LIST_NAME As String
  LIST_NAME = "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
書き直しに挑戦(→更新停止中…)

yuru-wota.hateblo.jp

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:機会があれば、自分でいじった部分は解説記事も作…れる、かなぁ…