よく使うVBAコードまとめ

一覧表

最近はAIが提示したコードを参考にコーディングしたりリファクタするので、あまり1から記述することはない。

リファレンスとして置いておくと便利なので展開する。

VBA

フォントの変更

Range("A1").Font.Name = "ＭＳ Ｐゴシック"

格子の挿入

#格子の挿入
ActiveSheet.Range("A5:K33").Borders.LineStyle = xlContinuous

値と書式の貼り付け

Paste:=xlPasteValuesAndNumberFormats, _

シート名の重複を確認する

Dim ws As Worksheet, flag As Boolean
    For Each ws In Worksheets
        If ws.Name = "合計" Then flag = True
    Next ws
    If flag = True Then
        MsgBox "[合計]シートがあります", vbInformation
    Else
        MsgBox "[合計]シートはありません", vbInformation
    End If

選択した画像を拡大する

Dim sh As Shape

' 選択した図形を一つずつ処理
For Each sh In Selection.ShapeRange
    sh.Width = 500
    sh.Height = 500
Next

実行確認ダイアログ

Dim alert As VbMsgBoxResult
alert = MsgBox(“実行してよろしいですか？”, vbYesNo + vbQuestion, “実行確認”)
If alert = vbYes Then

MsgBox “実行しました。” '←「はい」ボタンをクリックしたときの処理。

End If

印刷の実行

ActiveSheet.PrintOut

シートを確認なしで削除する

#シートを確認なしで削除
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True

非表示を全表示

ws.Cells.EntireRow.Hidden = False
ws.Cells.EntireColumn.Hidden = False

印刷範囲の複数設定

Dim ra As Range
Set ra = Range("A1:G5")
Set ra = Union(ra,"A8:G13")

'''ループでどんどんUnionしていくイメージ

ra.Name = "印刷範囲"
ActiveSheet.PageSetup.PrintArea = "印刷範囲"

文字列の一部だけ色を変えるやつ

#4文字目から3文字分
ActiveCell.Characters(Start:=4, Length:=3).Font.ColorIndex = 3

左揃えにするやつ

range1.HorizontalAlignment = xlLeft

3桁区切りで表示するやつ

Range(“A1”) = Format(Range(“A1”), “#,###”)

改行の削除に使うやつ

ActiveSheet.Cells.Replace _
        What:=vbLf, _
        Replacement:="", _
        LookAt:=xlPart

シートの移動

Worksheets("印刷用シート").Select

値のみ貼り付け

xlPasteValues

セルを削除して上に詰める

' B2 セルを削除後に上方向にシフト
Range("B2").Select
Selection.Delete Shift:=xlUp

ローマ字(英字)を含むかどうかの判定

#英字を含まないとき、の書き方
Not Cells(1,1).Value Like "*[a-zA-Z]*" Then

色設定などを消す

#色、罫線、中身を消す
With Range(Rows(1), Rows(4))
        .Borders.LineStyle = xlLineStyleNone
        .ClearContents
        .Interior.ColorIndex = 0
End With

シートを1ページで印刷&印刷プレビュー

ActiveSheet.PageSetup.Zoom = False
ActiveSheet.PageSetup.FitToPagesTall = 1
ActiveSheet.PageSetup.FitToPagesWide = 1
ActiveSheet.PrintPreview

印刷範囲の設定

'印刷範囲の設定
    Dim out_page_print As Range
    Set out_page_print = Range(Cells(1, 1), Cells(last_name_row + 14, 9))

    out_page_print.Name = "特定対象_請求書印刷"
    ActiveSheet.PageSetup.PrintArea = "特定対象_請求書印刷"

    With Sheets(new_sheetName).PageSetup
       .Zoom = False
       .FitToPagesTall = 1
       .FitToPagesWide = 1
    End With

セルの塗りつぶし

Range("B3").Interior.Color = RGB(0, 0, 255)  ''青色に設定します

sum関数の挿入

Cells(11, 1).FormulaR1C1 = "=Sum(R[-3]C:R[-1]C)"

#相対参照に変数
R[" & aaa &"]C1

日付関連

'本日の日付の取得
Dim today_date As Date
today_date = Now

'date型からstringへの変換を行う変数
Dim today_year As String
Dim today_month As String

today_year = Format(today_date, "yyyy")
today_month = Format(today_date, "mm")

文字の大きさの変更

Range("A1").Font.Size = 15

#太字にする
Range("A1").Font.Bold = True

セルを結合して中央ぞろえ

With Range("A1:B2")
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Merge
End With

セルの結合

Range("A1:C3").Merge

列の幅の設定

Columns(2).ColumnWidth = 20
Range(Columns(2), Columns(3)).ColumnWidth = 20

行の高さの設定

Rows(2).RowHeight = 20
Range("2:3").RowHeight = 20
Range("2:2", "3:3").RowHeight = 20
Range(Rows(2), Rows(3)).RowHeight = 20
Range("A2:A3").EntireRow.RowHeight = 20

行の追加

#2行目に行を追加する
Rows(2).Insert

繰り返し処理を逆順に行う方法

For i = 100 To 1 Step -1

ウィンドウ枠の固定の解除に使うやつ

ActiveWindow.FreezePanes = False

図形の全削除に使うやつ

ActiveSheet.Shapes.SelectAll
Selection.Delete

シートの名前に+αしてコピーを作るやつ

'シート名の取得
Dim sheetName As String
sheetName = ActiveSheet.Name
sheetName = sheetName + "_" + cmb年度.Value + "_" + cmb月.Value
    
'シートコピーの処理
ActiveSheet.Copy After:=ActiveSheet
ActiveSheet.Name = sheetName

処理の高速化に使うやつ

Application.ScreenUpdating = False

アクティブシートの取得

Dim ws As Worksheet
Set ws = ActiveSheet

最終行の定義に使うやつ

Dim last_row_number As Integer
last_row_number = Cells(Rows.Count, 1).End(xlUp).Row
Debug.Print (last_row_number)

特定の文字列を探すやつ

*'入居判定が最初に出てくるセルを見つける
Dim calculate_rng As Range

'vbLfはセル内改行を表す。xlFOrmulasにすると非表示セルも検索できる
Set calculate_rng = Cells.Find(What:="月額合計" & vbLf & "(総合計)", LookIn:=xlFormulas, LookAt:=xlWhole)

'ここは保証会社セルの取得
calculate_column = calculate_rng.Column*

繰り返し処理に使うやつ

Sub 練習1()
　　Dim i
　　For i = 1 To 10
　　　　Cells(i, 1) = 1
　　Next i
End Sub

非表示・表示の切り替えに使うやつ

If Columns(calculate_column).Hidden = False Then
    Columns(calculate_column).Hidden = True
Else
    Columns(calculate_column).Hidden = False
End If

シート名の取得

Dim sheetName AS String
sheetName = ActiveSheet.Name

実行するかどうかの分岐に使うやつ

Dim alert As VbMsgBoxResult
alert = MsgBox("実行してよろしいですか？", vbYesNo + vbQuestion, "実行確認")
If alert = vbYes Then
処理内容
EndIf

翌日への繰り越し

預金残高等の管理において、毎日終業時間に「今日の残高を明日の朝一の残高にコピペして・・・」という作業をするのは面倒。

「E4:E5」の範囲を「C4:C5」にコピペし、元の部分を削除するコードは以下の通り。

Sub 繰越処理()

'実行するかの確認
Dim alert As VbMsgBoxResult
alert = MsgBox("翌日への繰越処理を実施します。実行してよろしいですか？", vbYesNo + vbQuestion, "実行確認")
If alert = vbYes Then

'シート名の取得
Dim sheetName As String
sheetName = ActiveSheet.Name

'作業を描画しない
Application.ScreenUpdating = False

'残高繰越
Worksheets(sheetName).Range("E4:E5").Copy
Worksheets(sheetName).Range("C4:C5").PasteSpecial _
                                 Paste:=xlPasteValues, _
                                 Operation:=xlNone, _
                                 SkipBlanks:=False, _
                                 Transpose:=False

'コピペして不要になった分の削除
Range("E4:E5").ClearContents

'描画を戻す
Application.ScreenUpdating = True
End If
End Sub

実行後の結果は以下の通り。

PDFでの書き出し

コードは以下の通り。

Sub save_as_pdf()
'ファイル名・保存場所の定義
    Dim export_FilePath As String

    export_FilePath = ThisWorkbook.Path & "\" & "PDFになりました" & ".pdf"
    
    ActiveSheet.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=export_FilePath
    
    Worksheets(1).Select
    
End Sub

上記では、

• ファイル名は「PDFになりました」
• 保存場所は「Excelファイルがある場所」

という設定になっている。

実行前に、PDFにしたい範囲を「印刷範囲」として設定しておこう。

VBAを実行した結果、PDFファイルが作成されたことが確認できる。

実行時間によって処理を変える

PDFの作成を応用してみる。

実行した時間によって、作成されるPDFのファイル名が変更されるようになっている。

コードは以下の通り。

Sub save_as_pdf()
'ボタンを押した時間によってファイル名を変更する
    Dim export_FilePath As String
    Dim lastnum As String
    
    Dim Mor, Aft, Eve, Nig
    Mor = CDate("08:0:0")
    Aft = CDate("12:0:0")
    Eve = CDate("14:45:0")
    Nig = CDate("20:0:0")
'    8:30-12:00まで
    If Time >= Mor And Time < Aft Then
        lastnum = "_001"
'    12:00-14:45まで
    ElseIf Time >= Aft And Time < Eve Then
        lastnum = "_002"
'    14:50-20:00までは
    ElseIf Time >= Eve And Time < Nig Then
        lastnum = "_003"
    Else
        lastnum = "999"
    End If
    
'ファイル名の日時部分の定義
    y = Year(Date)
    m = Format(Month(Date), "00")
    d = Format(Day(Date), "00")
    
    Dim todaynum As String
    todaynum = y & "_" & m & "_" & d
    export_FilePath = ThisWorkbook.Path & "\" & "PDFになりました" & todaynum & lastnum & ".pdf"

'PDFに保存する対象の定義

    ActiveSheet.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=export_FilePath
    
    Worksheets(1).Select
    
End Sub

15時に実行し、以下の結果を得た。

複数枚のシートを1つのPDFにする

以下のように、3つのシートを1つのPDFとして出力したい場合。

コードは以下の通り。

Sub save_as_pdf()
Dim export_FilePath As String

    
'ファイルパス & ファイル名を指定
export_FilePath = ThisWorkbook.Path & "\" & "3ページ分のPDF" & ".pdf"

'PDFに保存する対象の定義
Worksheets(Array("ページ1", "ページ2", "ページ3")).Select
    
ActiveSheet.ExportAsFixedFormat _
    Type:=xlTypePDF, _
    Filename:=export_FilePath
        
'ワークシートの複数選択を解除
    Worksheets(1).Select
    
End Sub

実行後、3ページのPDFが作成されていることが確認できる。

シートを別のブックに移動する処理

毎月処理している業務があり、月ごとに別のシートで作業しているとする。

以前のシートを参照しない場合、別のブックに保存しておきたい時がある。

(非表示や削除を好まない場合)

毎回、「別のブックを開く⇒シートの移動⇒別のブックを選択」という作業を行うのは面倒である。

コードは以下の通り。

Sub SheetMover()
'シート名の取得
Dim sheetName As String
sheetName = ActiveSheet.Name
Dim alert As VbMsgBoxResult
alert = MsgBox("シートの移動を行います。作業はすべて完了していますか？", vbYesNo + vbQuestion, "実行確認")
If alert = vbYes Then
If sheetName Like "*マスター*" Then
MsgBox "マスターシートの移動は行えません。"
End
End If
    Dim wbActive    As Workbook '// アクティブブック用
    Dim wbOpen      As Workbook '// 移動先ブック用
    
    '// アクティブブックを保持
    Set wbActive = ActiveWorkbook
    
    '// ブックを開く
    Set wbOpen = Workbooks.Open("C:\Users\ユーザー名\Desktop\保存する先のブックです.xlsx")
    
    '// 開いたブックの一番左のシートの右に移動
    Call wbActive.ActiveSheet.Move(After:=wbOpen.Worksheets(1))
End If
End Sub

注意点として

• 上記のユーザー名は自身のユーザー名に変更すること
• 保存する先のブックに同じ名前のシートが含まれていないこと

(メモリ不足のエラーが発生するため)

また、上記のコードではシート名に「マスター」が含まれている場合は移動ができないように設定している。

移動のパスについて

今回、対象のブックはデスクトップに保存している。

保存先のブックのパスを調べるには、プロパティを見るとよい。

「場所」のパスを記述すればよい。

隣のセルを(クリップボードに)コピー

マクロをボタンに登録して使うイメージ。

Sub passcopy()
 ActiveSheet.Shapes(Application.Caller).TopLeftCell.Offset(, -1).Copy
End Sub

上記コードは「ボタンの左をコピーする」記述。

Offsetは自身の場所から下図のように対象を参照する。

n列おきに、n行おきの合計を行う

• あ、い、うの合計を算出したい
• SUMIFではなく、「C2 + C5 + …」という数式をあえて表示したい
• 8が含まれている列は加算しない(=1列とばしで処理を行う)

なんのひねりもなく記述すると以下の通りになる。

Dim o
Dim p
Dim q

o = 26
For p = 3 To 7 Step 2
    For q = 0 To 2
        Cells(o + q, p).Formula = "=R[-24]C+R[-21]C+R[-18]C+R[-15]C+R[-12]C+R[-9]C+R[-6]C+R[-3]C"
    Next q
Next p

-24ならまだよいが、　-100を超えると手で打つのは非現実的。

その点考慮し、一般化すると以下の通り。

(重要な部分を見やすくするためqの分岐を行っていない。)

Dim o
Dim p
Dim start
Dim step_number
o = 26
For p = 3 To 7 Step 2
    start = "="
    For step_number = 3 To 24 Step 3
        start = start + "+R[-" & step_number & "]C[0]"
    Next step_number
    Cells(o, p).Value = start
    Cells(o + 1, p).Value = start
    Cells(o + 2, p).Formula = start
Next p

他のユーザーのために数式を表示せざるを得ない場合などに使う。。。かも。

フォームの呼び出し

Sub 確認メッセージの表示()
    account_checkform.Show
End Sub

特定の文字を含むセルを検索する

'「テスト」を見つける関数(対象セルの行、列を戻り値としている)
Sub text_cell_finder(text_row, text_col)
    Dim Rng As Range
    Set Rng = Cells.Find(What:="テスト", LookIn:=xlValues, LookAt:=xlWhole)
    '対象セルの行を取得
    calculate_row = Rng.row
        '対象セルの列を取得
    calculate_col = Rng.Column
End Sub

'上記の関数を呼び出す記述(対象セルの行、列が返ってくる)
Call test_cell_finder(test_row, test_col)

印刷範囲の設定

Dim out_page_print As Range
Set out_page_print = Range(Cells(1, 1), Cells(last_name_row + 14, 9))
out_page_print.Name = "特定対象_請求書印刷"
ActiveSheet.PageSetup.PrintArea = "特定対象_請求書印刷"

With Sheets(new_sheetName).PageSetup
   .Zoom = False
   .FitToPagesTall = 1
   .FitToPagesWide = 1
End With