【永久保存版,随時更新】Excel VBAの厳選超便利コード集

Excelを使った事務作業。
VBAを使うと面倒な業務が一瞬でできてしまって便利ですよね。
そこで、私が会社の業務で作成したVBAのコードの中でも、さまざまな局面に応用可能で汎用性が高いであろうコードを集めてみました。
リファレンスコードとしてご活用いただければ幸いです。

コードの細かい意味はよくわからないけれども、とにかく早く動くモノを作りたい・・・！！
そんなあなたに最適のコード集です。
これらを組み合わせるだけで、あなたが作ろうとする機能はほとんどできあがってしまうかもしれません。

説明および更新履歴のコメント

プログラムは一度作って終わりではなく、運用に変更があれば都度メンテナンスが必要になります。
そのため、プログラムの説明および、バージョンが分かるように更新履歴を書き加えておきましょう。

'■取扱説明
'┌────┬─────────────────────────────────
'│機能説明│XXX
'│　　　　│XXX
'├────┼─────────────────────────────────
'│注意事項│XXX
'│　　　　│XXX
'└────┴─────────────────────────────────
'
'■更新履歴
'┌──┬─────┬─────┬───────────────────────
'│Rev.│更新年月日│　更新者　│　更新内容
'├──┼─────┼─────┼───────────────────────
'│1.00│2016/10/31│山田　太郎│新規作成
'│1.01│2019/12/26│山田　花子│軽微な不具合修正
'└──┴─────┴─────┴───────────────────────

変数宣言と変数の型

変数宣言強制の決まり文句

モジュールの先頭で宣言します。そのモジュール内のすべての変数の明示的な宣言を強制します。

Option Explicit

変数名の入力ミス由来のバグ発生対策になります。これを書いておくのが無難です。

変数宣言

変数は以下のように宣言します。

Dim 変数名 As データ型

「As ～」の部分の変数の型の指定は省略可能です。
具体的には以下のようになります。

Dim i As Integer

変数の型は以下の通りです。

変数の型

データ型	型の名称	消費メモリ	格納できる範囲	初期値
Integer	整数型	2 byte	-32,768 ～ 32,767	0
Long	長整数型	4 byte	-2,147,483,648 ～ 2,147,483,647	0
Single	単精度浮動小数点数型	4 byte	【正の値】 1.401298E-45 ～ 3.402823E38 【負の値】 -3.402823E38 ～ -1.401298E-45	0
Double	倍精度浮動小数点数型	8 byte	【正の値】 4.94065645841247E-324 ～ 1.79769313486232E308 【負の値】 -1.79769313486232E308 ～ -4.94065645841247E-324	0
Currency	通貨型	8 byte	-922,337,203,685,477.5808 ～ 922,337,203,685,477.5807	0
Date	日付型	8 byte	西暦100年1月1日～ 西暦9999年12月31日までの 日付と時刻	1899/12/30 00:00:00
String	文字列型	2 byte	最大約20億文字まで	vbNullString
Object	オブジェクト型	4 byte	オブジェクトを参照するデータ型	Nothing
Variant	バリアント型	16 byte	可変長の文字列型の範囲と同じ	Empty
Boolean	ブール型	2 byte	True(真)またはFalse(偽)	False

プロシージャの最初と最後に入れたい文言

プログラムを呼び出す単位をプロシージャと呼び、以下の構文で記述します。

Sub プロシージャ名()

End Sub

プログラムをスムーズに動作させるため、以下の文言を最初と最後に入れておくことを推奨します。
プログラム実行中に画面の描画をなくすことで高速に動作させ、実行中に余計なメッセージが表示されないようになります。

■最初(“Sub プロシージャ名()”の直後)に入れる文言

'▼画面更新停止
    Application.ScreenUpdating = False

'▼確認メッセージを非表示に
    Application.DisplayAlerts = False

■最後(“End Sub”の直前)に入れる文言

'▼確認メッセージ表示設定を通常に戻す
    Application.DisplayAlerts = True

'▼画面更新再開
    Application.ScreenUpdating = True

さまざまな場所のファイルを開く

Target = "C:\Users\Public\Documents\xxx.xlsx"
If Dir(Target) <> "" Then
    Workbooks.Open Target
Else
    MsgBox Target & vbCrLf & "が存在しません"
    Exit Sub
End If

上記例では、”C:\Users\Public\Documents\xxx.xlsx”という名前のファイルがある場合にはそれを開き、無ければエラーメッセージを返す仕組みになっています。
ディレクトリ(階層)および、”xxx.xlsx”はもちろん好きな名前に変更していただけます。

また補足となりますが、5行目のvbCrLfはメッセージ中の改行を表します。

同じディレクトリ内のファイル

Target = ThisWorkbook.Path & "\xxx.xlsx"
If Dir(Target) <> "" Then
    Workbooks.Open Target
Else
    MsgBox Target & vbCrLf & "が存在しません"
    Exit Sub
End If

上記例では、VBAを記述しているExcelブックと同じディレクトリ(階層)内に”xxx.xlsx”という名前のファイルがある場合にはそれを開き、無ければエラーメッセージを返す仕組みになっています。
“xxx.xlsx”はもちろん好きな名前に変更していただけます。

Windowsの特殊フォルダ

VBAにおいてWindowsの”Windows Script Host”オブジェクトを使用することで、デスクトップフォルダやマイドキュメントなどの特殊フォルダのパスを取得できます。
以下はデスクトップのパスを取得し、デスクトップ内の”xxx.xlsx”という名前のファイルを開くソースです。

Target = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\xxx.xls"
If Dir(Target) <> "" Then
    Workbooks.Open Target
Else
    MsgBox Target & vbCrLf & "が存在しません"
    Exit Sub
End If

 

さらに、デスクトップ以外にもさまざまな種類の特殊フォルダを指定できます。

上記例1行目で”Desktop”となっている””の中身を、以下の表の中の特殊フォルダ名に変更することで、さまざまなパスを取得可能です。

特殊フォルダ名	取得できるパス
Desktop	デスクトップフォルダ
Favorites	お気に入りフォルダ
Fonts	フォントフォルダ
MyDocuments	マイドキュメントフォルダ
Programs	プログラムフォルダ
Recent	最近開いたファイルフォルダ
SendTo	送るフォルダ
StartMenu	スタートアップメニューフォルダ
StartUp	スタートアップフォルダ

上記の中に含まれないフォルダ、たとえば「ダウンロード」フォルダは出番がそれなりにありそうです。
インターネット上からDLしたcsvファイルのフルパスを変数に格納する場面を考えてみましょう。
Windows10において、マイドキュメントフォルダを利用して、それと同じ階層にある「Downloads」フォルダを参照するには、以下のコードを使います。

'▼インターネット上からDLしたcsvファイル名を変数に格納
    Dim CsvFileName As String
    CsvFileName = "foo.csv"

'▼csvファイルのフルパスを変数に格納
    Dim CsvFileFullPath As String
    CsvFileFullPath = CreateObject("Wscript.Shell").SpecialFolders("MyDocuments") & "\..\Downloads\" & CsvFileName

"\..\Downloads\"の中の\..の部分で1つ下の階層に移り、「Downloads」フォルダを参照する形になります。

さらに、”FileSystemObject”を使用してWindowsフォルダやSystem32フォルダ、テンポラリフォルダのパスも取得可能です。
以下はWindowsフォルダのパスを取得し、Windowsフォルダ内の”xxx.xlsx”という名前のファイルを開くソースです。

Target = CreateObject("Scripting.FileSystemObject").GetSpecialFolder(0)& "\xxx.xls"
If Dir(Target) <> "" Then
    Workbooks.Open Target
Else
    MsgBox Target & vbCrLf & "が存在しません"
    Exit Sub
End If

上記例1行目でGetSpecialFolder()となっている()の中身を、以下の表の中の数値に変更することで、さまざまなパスを取得可能です。

指定できる数値	取得できるフォルダ
0	Windowsフォルダ
1	System32フォルダ
2	Temporaryフォルダ

さまざまなセル範囲の指定

Excelを使う以上、もっとも基本的な記述はセル範囲の指定でしょう。

セル範囲の指定にはRangeプロパティまたはCellsプロパティを使用します。

指定したセル範囲の指定

まずは単一のセルを指定してみましょう。
書き方は非常に多くありますが、以下はすべてセル番地B1を選択するコードです。

' サンプル1
    Range("B1").Select
' サンプル2
    Cells(1, 2).Select
' サンプル3
    Cells(1, "B").Select
' サンプル4
    Cells.Item(1, 2).Select
' サンプル5
    Range(Cells(1, 2)).Select

一言にセル番地B2を指定といっても、非常に多くの書き方があります。
とはいっても、実際によく使うのはハイライトされた2,4行目の表記でしょう。

一見すると、Rangeプロパティの方が一般的によく見慣れたA1方式(アルファベットで列を、数字で行を表す方式)がそのまま使えるのでとっつきやすく感じます。

しかし、プログラミングを行っていくと、ループや条件分岐を行うことになります。

このとき、行・列どちらも数字で取り扱えるCellsプロパティの方が圧倒的に扱いやすいため、Cellsプロパティの記法になれることを強く推奨いたします。

なお、Rangeプロパティの引数は("B1")のように列→行の順番ですが、Cellsプロパティの引数は(1, 2)のように行→列の順番になることに注意してください。

続いては、複数セルの指定です。

' A1とC3(2セルのみ)を選択する
    Range("A1,C3").Select
' A1からC3までのセルすべて(9セル)を選択する その1
    Range("A1:C3").Select
' A1からC3までのセルすべて(9セル)を選択する その2
    Range("A1","C3").Select
' A1からC3までのセルすべて(9セル)を選択する その3
    Range("A1", Cells(3,3)).Select
' A1からC3までのセルすべて(9セル)を選択する その4
    Range(Cells(1,1), Cells(3,3)).Select
' A1からC3までのセルすべて(9セル)を選択する その5
    Range("A1:A3","C1").Select

単一セルの場合以上に多種多様な選択方法がありますが、実際によく使うのはハイライトされた2,4,10行目の表記でしょう。
12行目の書き方はぱっと見理解不能ですが、要するに『Range(Cell1,Cell2)』と書いた時、Cell1とCell2をすべてピッタリと収納する長方形の範囲を選択するということです。
文章だと分かりにくいですが、下記の画像をご確認ください。

指定した行範囲の指定

まずは行からです。サンプルを以下に示します。

' 1 単一の行を選択する
    Range("3").Select
' 2 複数の行を選択する
    Range("1:3").Select
' 3 1と同様に複数の行を選択する
    Rows("1:3").Select
' 4 連続していない複数の行(下記例は1～3,5～7,10行目)を選択する
    Range("1:3, 5:7, 10:10").Select

変数iおよびjを用いて、i行目からj行目までの行すべてを選択するコードは以下になります。

Rows(i & ":" & j).Select

指定した列範囲の指定

続いては列です。A1形式で選択すると、下記

' 1 "Sheet1"の単一の列を選択する
    Sheet1.Columns("C").Select 
' 2 1と同様に"Sheet1"の単一の列を選択する
    Sheet1.Columns(3).Select
' 3 "Sheet1"の複数の列を選択する
    Sheet1.Columns("C:E").Select

しかしながら、Columnsプロパティで列番号を用いて、複数列を指定する事は出来ません。

' 1 "Sheet1"の複数の列を、列番号を用いて選択する
    With Sheet1
        .Range(.Columns(3), .Columns(5)).Select
    End With
' 2 "Sheet1"の複数の行を、行番号を用いて選択する
    With Sheet1
        .Range(.Rows(3), .Rows(5)).Select
    End With

離れたセル範囲の指定

続いて離れたセル範囲を指定してみましょう。

' 1 A列・C～D列・F列を選択する(その1)
    Range("A:A, C:D, F:F").Select 
' 2 A列・C～D列・F列を選択する(その2)
    Dim rng As Range
    Set rng = Union(Range("A:A"), Range("C:D"))   ' A列とC～D列
    Set rng = Union(rng, Columns(6))              ' A列とC～D列とF列
' 3 A1～A3およびC1～C3を選択する
    Union(Range(Cells(1, 1), Cells(3, 1)), Range(Cells(3, 1), Cells(3, 3))).Select

値が入っている最終行・最終列の取得

With ActiveSheet.UsedRange
    MaxRow = .Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
    MaxCol = .Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
End With

MaxRow=最終行
MaxCol=最終列
として取得可能です。もちろん変数名(MaxRow, MaxCol)は好きな名前に変えていただいて構いません。
どちらか片方だけでよい場合は、Withステートメントを使用せず、下記のようなコードでOKです。

 

【最終行の取得】

MaxRow = ActiveSheet.UsedRange.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row

 

【最終列の取得】

MaxCol = ActiveSheet.UsedRange.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column

 

このコードは途中で空白行・列があっても問題なく動作し、Excelのバージョンを問わず、書式のみ付いているセル(例えば、背景色がついているセル)は除外して判断する優れたコードです。
以下のサイトでその詳細が記載されておりますので、詳しく知りたい方はご覧ください。

応用と不要な画面描画抑止

最終行を取得するコードを紹介しましたので、それを使った応用コードを以下に記載します。
下記は、全データレコードのうち、B列(2行目以降)がブランクである行をすべて削除するコードになります。
実際のVBAプログラミングでも不要行削除はよくあるケースですので、参考にしてください。

Sub 不要行削除()

    Application.ScreenUpdating = False '不要な画面描画を抑止
    MaxRow = ActiveSheet.UsedRange.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
    i = 2
    Do While i <= MaxRow
        If Range("B" & i).Value = "" Then
            Rows(i).Delete Shift:=xlUp
            MaxRow = ActiveSheet.UsedRange.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
        Else
            i = i + 1
        End If
    Loop
    
End Sub

オートフィルタの結果をコピーする

    Dim A As Range, B As Range
    Rows("1:1").Select
    Selection.AutoFilter
    ActiveSheet.Range("A1:E" & Mr).AutoFilter Field:=5, Criteria1:="<>0", _
        Operator:=xlAnd
    With ActiveSheet.AutoFilter
        Set A = Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible)
        Set B = Range(.Range(1).Offset(1, 0), .Range(.Range.Count))
    End With

    Set Target = Application.Intersect(A, B)

Excelのデータを別アプリケーションに貼り付け

任意のセル範囲をPowerPointに貼り付け

Sub CopyToPPT()
  Dim ppApp As Object 'PowerPointアプリ
  Dim ppPst As Object 'PowerPointプレゼン
  Dim ppSld As Object 'PowerPointスライド
  Dim ppW As Single, ppH As Single, i As Integer
 
  On Error Resume Next
  'PowerPointを起動
  Set ppApp = CreateObject("PowerPoint.Application")
  If ppApp Is Nothing Then
    On Error GoTo ERROR_HANDLER
    Err.Raise 1000, , "PowerPoint の起動に失敗しました"
  End If
 
  On Error GoTo ERROR_HANDLER
   
  'PowerPointを表示
  ppApp.Visible = msoTrue
  'PowerPoint新規プレゼンテーション作成
  Set ppPst = ppApp.Presentations.Add(WithWindow:=True)
  'PowerPoint画面最大サイズを取得
  With ppPst.PageSetup
    ppH = .SlideHeight
    ppW = .SlideWidth
  End With
   
  'Excel各シートの貼り付け
  For i = 1 To ThisWorkbook.Worksheets.Count
    '指定範囲をクリップボードにコピー
    ThisWorkbook.Worksheets(i).Range("C3:AL29").CopyPicture xlScreen, xlPicture
    'PowerPointスライド追加
    Set ppSld = ppPst.Slides.Add(Index:=i, Layout:=12)
    '貼り付け
    ppSld.Shapes.Paste
    'PowerPointグラフ位置・サイズを最大になるように補正
    With ppSld.Shapes(1)
      .LockAspectRatio = msoFalse
      .Top = 0
      .Left = 0
      .Height = ppH
      .Width = ppW
    End With
  Next i
   
  'PowerPointを保存
  ppApp.ActivePresentation.SaveAs Filename:=ThisWorkbook.Path & "\" & Replace(ActiveWorkbook.Name, ".xlsm", ".pptx")
     
TERMINATE:
  On Error GoTo 0
  Set ppApp = Nothing
  Set ppPst = Nothing
  Set ppSld = Nothing
  Exit Sub
     
ERROR_HANDLER:
  MsgBox Err.Description, vbCritical
  Resume TERMINATE
End Sub

印刷範囲をpdf化

Sub ToPDF()
  Dim strSheetName As String, fileNameCell As String
  strSheetName = ActiveSheet.Name
  fileNameCell = "G8" 'ファイル名をこのセルの値から取得

  With Range(fileNameCell)
    If .Value <> "" Then
      If InStr(.Value, "\") > 0 Or _
         InStr(.Value, "/") > 0 Or _
         InStr(.Value, ":") > 0 Or _
         InStr(.Value, "*") > 0 Or _
         InStr(.Value, "?") > 0 Or _
         InStr(.Value, """") > 0 Or _
         InStr(.Value, "<") > 0 Or _
         InStr(.Value, ">") > 0 Or _
         InStr(.Value, "|") > 0 Or _
         InStr(strSheetName, "\") > 0 Or _
         InStr(strSheetName, "/") > 0 Or _
         InStr(strSheetName, ":") > 0 Or _
         InStr(strSheetName, "*") > 0 Or _
         InStr(strSheetName, "?") > 0 Or _
         InStr(strSheetName, """") > 0 Or _
         InStr(strSheetName, "<") > 0 Or _
         InStr(strSheetName, ">") > 0 Or _
         InStr(strSheetName, "|") > 0 Then
      MsgBox "セル" & fileNameCell & "またはシート名にファイル名に使えない文字(\/:*?" & """" & "<>|)が含まれています。", vbExclamation
    Else
      ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
      Filename:=ThisWorkbook.Path & "\" & strSheetName & "_" & .Value & ".pdf", _
      Quality:=xlQualityStandard, _
      IncludeDocProperties:=True, _
      IgnorePrintAreas:=False, _
      OpenAfterPublish:=True, _
      From:=1, _
      To:=1
    End If
    Else
      MsgBox "セル" & fileNameCell & "にファイル名が入力されていません。", vbExclamation
    End If
  End With
End Sub