World Financial Strategy

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

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

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

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

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 スタートアップフォルダ

さらに、”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フォルダ

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

指定したセル範囲の指定

まずは単一のセルを指定してみましょう。
書き方は非常に多くありますが、以下はすべてセル番地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行目の表記でしょう。

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

' 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

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

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

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

スポンサーリンク
WFS用レクタングル(大)
WFS用レクタングル(大)

シェアする

  • このエントリーをはてなブックマークに追加
トップへ戻る