Excel VBAをたまに使うから記述を個人用にメモ

処理が速くなる設定

' 自動計算を停止
Application.Calculation = xlCalculationManual

' 画面表示の更新を停止
Application.ScreenUpdating = False

' イベントの発生を停止
Application.EnableEvents = False

' 何かしらの処理

' 設定を元に戻す
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True

1行で変数の宣言と代入。

' 文字列
Dim str As String: str = "test"

' WorkSheetオブジェクト
Dim ws As Worksheet: Set ws = Worksheets("Sheet1")

例外処理

On Error GoTo Exception

' 何かしらの処理

Exception:
    ' エラー未発生時はここで処理を終了させる
    If Err.Number = 0 Then        
        Exit Sub
    End If    
    Dim ans As Integer: ans = MsgBox("エラーコード：" & Err.Number & vbCrLf & Err.Description, vbExclamation, "エラー")

表の一番最後の行番号を取得(空白行はスキップする）

' ワークシートオブジェクト取得
Dim ws As Worksheet: Set ws = Worksheets("Sheet1")

' B列の最後の行番号_取得
Dim endRow As String: endRow = ws.Cells(Rows.Count, "B").End(xlUp).Row

1列の値を配列にする

' ワークシートオブジェクト取得
Dim ws As Worksheet: Set ws = Worksheets("Sheet1")

Dim arr() As Variant

' B列の1行目～10行目の値をリスト化
arr = WorksheetFunction.Transpose(ws.Range("B1:B10").Value)

' B列全ての値をリスト化
arr = WorksheetFunction.Transpose(ws.Range("B:B").Value)

配列の値でデータの入力規則(リスト)を更新する

' ワークシートオブジェクト取得
Dim ws As Worksheet: Set ws = Worksheets("Sheet1")

' リスト作成
Dim ListData As Variant: ListData = Array("函館", "仙台", "成田")

' B列の1行目～10行目の入力規則リストの値を更新
With ws.Range("B1:B10").Validation
    .Delete '既存のリストを削除
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=Join(ListData, ",")
End With

シート名でシートが存在するかチェックする関数

' 存在する場合はTrue,存在しない場合はFalseを返す
Public Function ExistsSheet(ByVal bookName As String)
    Dim ws As Variant
    For Each ws In Sheets
        If LCase(ws.Name) = LCase(bookName) Then
            ExistsSheet = True ' 存在する
            Exit Function
        End If
    Next
    ' 存在しない
    ExistsSheet = False
End Function

ピボットテーブルの作成

以下の様な「人件費」シートの表と「アルバイト」シートがあった場合、月別支給一覧表ピボットを作成

人件費

アルバイト

月別支給一覧(ピボット)



Sub CreatePivot()

    On Error GoTo Exception

        ' 自動計算を停止
        Application.Calculation = xlCalculationManual
        
        ' 画面表示の更新を停止
        Application.ScreenUpdating = False
        
        ' イベントの発生を停止
        Application.EnableEvents = False    
    
        ' シートオブジェクト取得
        Dim paySheet As Worksheet: Set paySheet = Worksheets("人件費")
        
        ' 人件費一覧テーブルのB列の最下行を取得
        Dim endPayTblRow As String: endPayTblRow = paySheet.Cells(Rows.Count, "B").End(xlUp).Row
        
        ' ソース範囲の取得
        Dim paySrcRng As Range: Set paySrcRng = paySheet.Range("B4:F" + endPayTblRow)
    
        Dim pvtShtName As String: pvtShtName = "月別支給一覧"
        Dim pvtName As String: pvtName = "集計ピボット"
        Dim pvtSheet As Worksheet
        Dim pvt As Excel.PivotTable
    
        ' シートの存在チェック
        If Not ExistsSheet(pvtShtName) Then
        
            ' シート追加
            Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = pvtShtName
                
        End If
        
        ' ピボットテーブルシートオブジェクト取得
        Set pvtSheet = Worksheets(pvtShtName)
        
        
        ' シートオブジェクト取得
        Dim castSheet As Worksheet: Set castSheet = Worksheets("アルバイト")
    
        ' アルバイト一覧表のB列の最後の行番号_取得
        Dim endCastTableRow As String: endCastTableRow = castSheet.Cells(Rows.Count, "B").End(xlUp).Row
    
        ' プルダウン用キャスト情報一覧_取得
        Dim casts() As Variant: casts = WorksheetFunction.Transpose(castSheet.Range("B5:B" & endCastTableRow).Value)
    
         ' ユーザー設定リスト番号
        Dim ListNum As Long
    
        ' 登録位置を取得
        ListNum = Application.GetCustomListNum(casts)
    
         ' ユーザー設定リストがすでに登録されているか確認する
        If ListNum = 0 Then
    
            'ユーザー設定リストに追加、登録位置を取得
            Application.AddCustomList Listarray:=casts
            ListNum = Application.GetCustomListNum(casts)
    
        End If
    
        With pvtSheet.Cells
            .Clear
            .ColumnWidth = .Parent.StandardWidth
            Application.Goto Reference:=.Item(1), Scroll:=True
        End With
    
    
        ' ピボットテーブルの存在チェック
        If pvtSheet.PivotTables.Count = 0 Then
    
            ' ピボットキャッシュ作成 → ピボットテーブル作成
            ThisWorkbook.PivotCaches.Create(xlDatabase, paySrcRng).CreatePivotTable Sheets(pvtShtName).Range("B2"), pvtName
    
            ' ピボットテーブルオブジェクト取得
            Set pvt = pvtSheet.PivotTables(pvtName)
    
    
            With pvt

                ' 行ラベル設定
                .PivotFields("名前").Orientation = xlRowField
                
                ' 列ラベル設定
                .PivotFields("勤務日").Orientation = xlColumnField
    
                
                ' データラベル(Σ値)設定
                With .PivotFields("日当")
                    .Orientation = xlDataField
                    .NumberFormat = "_ * #,##0_ ;_ * -#,##0_ ;_ * ""-""_ ;_ @_ "
                    .Caption = "日当額"
                End With
                
                With .PivotFields("源泉所得税")
                    .Orientation = xlDataField
                    .NumberFormat = "▲_ * #,##0_ ;_ * -#,##0_ ;_ * ""-""_ ;_ @_ "
                    .Caption = "源泉所得税額"
                End With
                
                With .PivotFields("支給")
                    .Orientation = xlDataField
                    .NumberFormat = "_ * #,##0_ ;_ * -#,##0_ ;_ * ""-""_ ;_ @_ "
                    .Caption = "支給額"
                End With
         
                .PivotFields("値").Orientation = xlRowField
    
                ' 総計を表示しない
                .ColumnGrand = False
                .RowGrand = False
    
                ' ピボットテーブルを表形式で表示
                .RowAxisLayout xlTabularRow
                
                ' 空のセルに0を表示
                .DisplayNullString = False
            End With
    
    
            ' 日付を年月単位でグループ化
            pvt.PivotFields("勤務日").AutoGroup
            pvtSheet.Range("E2").Select
            Selection.Group Start:=True, End:=True, Periods:=Array(False, False, False, False, True, False, True)
    
    
        End If
    
    
        ' ピボットテーブルオブジェクト取得
        Set pvt = pvtSheet.PivotTables(pvtName)
        
        ' 小計を表示しない
         Dim pvtFld As PivotField
         On Error Resume Next
         For Each pvtFld In pvt.PivotFields
             pvtFld.Subtotals(1) = True
             pvtFld.Subtotals(1) = False
         Next pvtFld
         On Error GoTo 0
    
    
        ' データソースを変更する
        pvt.ChangePivotCache ActiveWorkbook.PivotCaches.Create(xlDatabase, paySrcRng)
    
        
        ' ピボットテーブル全体のレイアウト
        pvtSheet.Activate
        pvtSheet.Range("B4").CurrentRegion.Select
        With Selection
            ' フォント変更
            .Font.Name = "Meiryo UI"
                    
            ' 垂直方向に上下中央揃え
            .VerticalAlignment = xlCenter
    
        End With
        
        ' データ部(ヘッダー以外)のレイアウト
        Dim NoHeaderRng As Range: Set NoHeaderRng = Selection.Offset(3, 1).Resize((Selection.Rows.Count - 3), (Selection.Columns.Count - 1))
        With NoHeaderRng
    
            .RowHeight = 28
            
             ' 罫線
            .Borders.LineStyle = True
    
        End With
        
        ' 行ラベル毎に下二重罫線を引く
        Dim PvtItem As PivotItem
        For Each PvtItem In pvt.PivotFields("名前").PivotItems
            
            pvt.PivotSelect "'" & PvtItem.Caption & "'", xlLabelOnly
            With Selection.Borders(xlEdgeBottom)
                .LineStyle = xlDouble
                .Weight = xlThick
                .ColorIndex = 1
            End With
                    
        Next PvtItem
        
    
        pvt.PivotSelect "'" & pvt.PivotFields("値").PivotItems(pvt.PivotFields("値").PivotItems.Count).Caption & "'", xlDataAndLabel
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlDouble
            .Weight = xlThick
            .ColorIndex = 1
        End With
                        
        
        ' セル幅を値に合わせる
        pvtSheet.Cells.Select
        pvtSheet.Cells.EntireColumn.AutoFit
    
        
        ' ウィンドウ枠の固定
        pvtSheet.Range("C5").Select
        ActiveWindow.FreezePanes = True
        
        
        ' A列の幅を細くする
        pvtSheet.Columns(1).ColumnWidth = 1
        
        
        '追加したユーザー設定リストを消去
        With Application
            .DeleteCustomList ListNum:=.GetCustomListNum(Listarray:=casts)
        End With
    
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
        Application.EnableEvents = True
        
        MsgBox "集計が完了しました。"

Exception:

    ' エラー未発生時はここで処理を終了させる
    If Err.Number = 0 Then
        
        Exit Sub
    
    End If
    
    Dim ans As Integer: ans = MsgBox("エラーコード：" & Err.Number & vbCrLf & Err.Description, vbExclamation, "エラー")

End Sub


Public Function ExistsSheet(ByVal bookName As String)
    Dim ws As Variant
    For Each ws In Sheets
        If LCase(ws.Name) = LCase(bookName) Then
            ExistsSheet = True ' 存在する
            Exit Function
        End If
    Next

    ' 存在しない
    ExistsSheet = False
End Function