【Excel VBA】コピペで使えるVBAコード集

## この記事は何
Excelマクロ(VBAコード)のサンプル集です。
VBAのコーディングに時間を割くのは勿体ないので、よく使うであろうコードをまとめました。
~~随時追加・修正していきます。~~ 
2022/10/25追記：VBAの現場から退いたので更新することはもう無いと思います。

## 基本編

### メッセージを表示する (MsgBox)
備考：第2引数は「+」で追加して連結する

```VB:
Sub Message()
    MsgBox "Hello World!", vbInformation, "タイトル"

    MsgBox "警告アイコン", vbCritical	  '値：16
    MsgBox "問い合わせアイコン", vbQuestion	 '値：32
    MsgBox "注意アイコン", vbExclamation	  '値：48
    MsgBox "情報アイコン", vbInformation	  '値：64

    'MsgBoxの戻り値で分岐 (If文)
    If MsgBox("良いですか？", vbOKCancel + vbQuestion, "確認1") = vbCancel	Then
        MsgBox "「Cancel」が押されました。"
        Exit Sub
    End If

    'MsgBoxの戻り値で分岐 (Select Case文)
    Select Case MsgBox("どうしますか？", vbYesNo + vbQuestion + vbDefaultButton2, "確認2")
    Case vbYes
        MsgBox "「はい」が押されました。"
    Case vbNo
        MsgBox "「いいえ」が押されました。"
    End Select
End Sub
```
![MsgBox.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/2513605/271b5adb-8b9a-3e49-79af-4710a3894f15.png)


### ログ出力 (Debug.Print)
イミディエイトウィンドウ内に出力される。
💡イミディエイトウィンドウを表示する設定にしておきましょう。

```VB:
Debug.Print "ログだよ～(o・∇・o)"
```


### 最終行・最終列の取得
格納する変数はInteger型にしてしまうと32,767行以上でオーバーフローするので注意！
```VB:
'最終行・最終列の取得
Dim End_Row As Long, End_Col As Long
End_Row = Cells(Rows.Count, 2).End(xlUp).Row      '最終行（2列目）
End_Col = Cells(3, Columns.Count).End(xlToLeft).Column   '最終列（3行目）
```

### 書式設定
```VB:
'セルの結合
Range(Cells(1, 1), Cells(2, 1)).Merge    '縦2セル
Range(Cells(3, 1), Cells(3, 3)).Merge    '横3セル
```

```VB:
'表示形式
With Range(Cells(7, 7), Cells(12, 7))   '指定範囲
    .NumberFormatLocal = "@"     'テキスト型
    .WrapText = False      'テキスト折り返し
    .VerticalAlignment = xlTop    '垂直位置  上詰め
    .HorizontalAlignment = xlGeneral    '水平位置  標準
End With
        
With Range(Cells(8, 8), Cells(13, 8))
    .NumberFormatLocal = "yyyy/mm/dd"   '日付 / 時刻型
    .VerticalAlignment = xlCenter    '垂直位置  中央揃え
    .HorizontalAlignment = xlLeft    '水平位置  左詰め
End With

With Range(Cells(5, 5), Cells(10, 5))
    .NumberFormatLocal = "#,##0_ ;[赤]-#,##0_ "   '数値型(マイナス：不等号・赤文字)
    .VerticalAlignment = xlBottom    '垂直位置  下詰め
    .HorizontalAlignment = xlRight    '水平位置  右詰め
End With

With Range(Cells(6, 6), Cells(11, 6))
    .NumberFormatLocal = "0.0%"    'パーセント(小数第1位まで)
    .VerticalAlignment = xlDistributed    '垂直位置  均等割り付け
    .HorizontalAlignment = xlCenter    '水平位置  中央揃え
End With
```
```VB:
'背景色の設定
With .Cells(15, 15)
    'Excel定数
    .Interior.Color = vbYellow   'セル背景色：黄色
    .Font.Color = vbRed   '文字色：赤
    'RGB関数
    .Interior.Color = RGB(171, 219, 227)   'セル背景色：ターコイズ
    .Font.Color = RGB(204, 255, 204)   '文字色：緑
End With
```
```VB:
'グラデーション設定
With Range(Cells(1, 1), Cells(1, 3)).Interior   'Range内の背景色
    .Pattern = xlPatternLinearGradient
    With .Gradient
        .Degree = 90 'グラデーションの角度(0～360°)
        With .ColorStops 'グラデーションの切替ポイントの設定
            .Clear '最初に初期化
            'グラデーションの切替ポイント(0～1)を追加して色を設定
            .Add(0).Color = RGB(255, 255, 255)
            .Add(1).Color = RGB(255, 153, 204)
        End With
    End With
End With
```
```VB:
'ハイパーリンク
With ThisWorkbook.Worksheets(1)
    .Hyperlinks.Add Anchor:=.Cells(10, 4), _
    Address:="https://www.yahoo.co.jp/"
End With
```

```VB:
'行の高さ
Rows("1:3").RowHeight = 15    '1～3行目  高さ15
'列の幅
Range(Columns(3), Columns(5)).ColumnWidth = 12    '3～5列目  幅12
```

```VB:
'ウィンドウ枠の固定
With ThisWorkbook.Worksheets(1)
    .Activate
    .Range("B3").Select
    ActiveWindow.FreezePanes = True
End With
```

### Select Case文
意外と記法を忘れやすい。

```VB:
Const ABC = "momo"
Select Case ABC
    Case "momo"
         MsgBox "pink"
    Case "sora"
         MsgBox "blue"
    Case "shiina"
         MsgBox "yellow"
    Case Else
         MsgBox "other"
End Select
```

### 文字を入力させる（InputBox）
初期値あり、キャンセルボタン処理も対応

```VB:
Sub Input01()
    Dim ans As String  ' InputBoxの戻り
    Dim flg As Boolean: flg = False
    Do
        ans = InputBox(Prompt:="入力してください。", Default:="初期値")
        If StrPtr(ans) = 0 Then Exit Sub  ' キャンセル時に終了
        If ans <> "" Then flg = True   '空白でなければループ抜ける
    Loop Until flg = True
    
    MsgBox ans
End Sub
```

### よく使う文の組み合わせ
新規ブックを作成し、各種書式設定を行う

```VB:
Sub Example()
    Dim wb As Workbook, ws As Worksheet
    Set wb = Workbooks.Add    '新規ブック作成
    Set ws = wb.Worksheets(1)  '1シート目を指定
    '-------------------------------------------------------------------
    With ws
        .Name = "シート名"
        Columns(1).ColumnWidth = 6   '1列目の列幅6
        '-------------------------------------------------------------------
        'ヘッダー作成
        ReDim HeaderArr(3)
        HeaderArr(0) = "No."
        HeaderArr(1) = "Name"
        HeaderArr(2) = "Date"
        HeaderArr(3) = "Label"
        With Range(.Cells(1, 1), .Cells(1, 4))
            .Value = HeaderArr    'ヘッダーの配列を範囲に貼り付け
            .Interior.Color = RGB(197, 217, 241)
            .Borders.LineStyle = 1    '罫線種類
            .Borders.Weight = 2    '罫線太さ
            .HorizontalAlignment = xlCenter
            .AutoFilter    'オートフィルター
        End With
        '-------------------------------------------------------------------
        '行番号を振る
        Dim i As Long    'Integerだと32,767行超える時にオーバーフローするのでLong推奨
        Dim LineNo() As String
        ReDim LineNo(1 To 20, 1 To 1)
        For i = 1 To 20
            LineNo(i, 1) = i
        Next i
    
        With Range(.Cells(2, 1), .Cells(UBound(LineNo) + 1, 1))
            .Value = LineNo    '配列をバッと貼る
            .Interior.Color = vbYellow    '背景色
        End With
        '-------------------------------------------------------------------
        '罫線を引く
        With .Range(.Cells(1, 1), .Cells(UBound(LineNo) + 1, 4))
            .Borders.LineStyle = xlContinuous
            .Borders.Weight = xlThin
        End With
        '-------------------------------------------------------------------
        '入力規則を設定（プルダウン選択リスト）
        Dim items() As Variant
        items = Array("ゆい,かおり")    'カンマ区切りだがダブルクォートは両端のみ
        With Range(.Cells(2, 2), .Cells(21, 2)).Validation
             .Delete    '元の設定を削除
             .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=Join(items, ",")
        End With
        '-------------------------------------------------------------------
        .Columns("A:D").AutoFit    '列幅自動調整
        .Cells(1, 1).Activate    'A1を選択状態に
    End With
    '-------------------------------------------------------------------
End Sub

```


### ブックオープン時に自動実行
※標準モジュールに書く場合、他のブックからオープンされると実行されないので注意。

```VB:標準モジュール
Private Sub Auto_Open()
    MsgBox "開かれました!"
End Sub
```

▼こちらは必ず実行される

```VB:ThisWorkbook
Private Sub Workbook_Open()
    MsgBox "開かれました!"
End Sub
```
### アドイン形式（.xlam）の自動実行について
VBA内でオートメーションで別プロセスのExcelを立ち上げた場合、xlamファイルのアドインは読み込まれない。Auto_Openも無効。

Excel2010で新規Excel立ち上げると新プロセスとして起動(xlamのAuto_Openがここで実行される)
Excel2013以降で新規Excel立ち上げると既存プロセスの別ブックとして起動(xlamのAuto_Openは実行されない)

### 描画停止で処理高速化
セルに変更を加える処理をループで回す場合に、描画を止めると早くなるという定石がある。
以下コード、時間計測のおまけ付き

```VB:
Dim st As Double: st = Timer    '時間計測開始

Application.ScreenUpdating = False      '描画停止
Application.Calculation = xlCalculationManual     '自動計算停止
'-------------------------------------------------------------------
'ここで時間のかかる処理
'-------------------------------------------------------------------
Application.Calculation = xlCalculationAutomatic    '自動計算
Application.ScreenUpdating = True      '描画再開

Debug.Print "処理時間 " & Round(Timer - st, 2) & " sec."
```

### 読み取り専用に変更
```VB:
If ThisWorkbook.ReadOnly = False Then  '現在の設定が読み取り専用でないかチェック
    ThisWorkbook.ChangeFileAccess Mode:=xlReadOnly  '読み取り専用に変更
End If

'逆に書き込みを許すとき↓
ThisWorkbook.ChangeFileAccess (xlReadWrite)
```

### 参照設定について
CreateObjectを使うと参照設定する必要がなくなる⇒遅延バインディング
（参照設定はブック毎に個別設定が必要で面倒）
「ツール」→「参照設定」で必要なものにチェックを付ける。
⇒事前バインディング

ただし、遅延バインディングは各種定数が自動補完されず、数値を直で入力する必要がある。
例：adOpenKeyset → 1

### ファイル操作 (FileSystemObject)


```VB:
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")

'ファイルコピー
FSO.CopyFile "コピー元パス", "コピー先パス", True     '第3引数Trueで上書きコピー

'ファイル移動
FSO.MoveFile "移動元パス", "移動先パス"
'移動先にすでに同名ファイルが存在する場合はエラー
'移動元ファイルは読み取り専用でも移動される

' ファイル削除
FSO.DeleteFile "ファイルパス", True
'引数forceは省略可。Trueを指定すると読み取り専用ファイルも削除される。

' ファイル存在確認
If FSO.FileExists("ファイルパス") Then
    Debug.Print "あるよ"        
End If

Debug.Print FSO.GetParentFolderName("ファイルパス")    '親フォルダのパスを取得

Debug.Print FSO.GetFileName("ファイルパス")    'ファイル名と拡張子を取得

Debug.Print FSO.GetBaseName("ファイルパス")    '拡張子なしファイル名を取得

Debug.Print FSO.GetExtensionName("ファイルパス")    '拡張子のみを取得

'ファイル更新日時系
Dim f As Object
Set f = FSO.GetFile("ファイルパス") 'ファイルを取得
Debug.Print f.DateLastModified    '更新日時を取得
Debug.Print f.DateCreated         '作成日時を取得
Debug.Print f.DateLastAccessed    'アクセス日時を取得

Set FSO = Nothing
```
:::note warn
MoveFileは同名パスが既に存在するとエラーになるのでFileExistsと組み合わせるのを推奨
:::

### UTF-8のテキストファイルを読み込む
VBAはデフォルトではShift_JISしか読めないのでADODB.Streamを利用する。

```VB:
Dim buf As String
With CreateObject("ADODB.Stream")
    .Charset = "UTF-8"
    .Open
    .LoadFromFile "ファイルパス"
    buf = .ReadText   '全データがbufに入る
    .Close
End With
```


### HTTPリクエストで文字列を取得
取得した値はベタのHTMLなのでスクレイピング用途には加工が必要

```VB:
    Dim URL As String
    URL = "http://abehiroshi.la.coocan.jp/"
    Dim respText As String    ' レスポンス
    '-------------------------------------------------------------------
    'HTTPリクエスト準備
    Dim httpReq As Object   ' MSXMLオブジェクト
    Set httpReq = CreateObject("MSXML2.XMLHTTP")   ' MSXMLオブジェクト生成
    '-------------------------------------------------------------------
    httpReq.Open "GET", URL, False    ' False  は同期処理
    httpReq.send    ' HTTPリクエストの送信

    If httpReq.Status = 200 Then    '200で正常取得
        respText = httpReq.responseText
        Debug.Print respText
    Else
        MsgBox "サーバー接続エラー" _
        & vbCrLf & httpReq.Status & " " & httpReq.statusText, vbCritical, "タイトル"
        Exit Function
    End If
```


### ADODBでSQL Serverに接続
参照設定する場合は ActiveX Data Objects 6.1 Library を有効化しておく
ADOはOracleとかも使える(後日サンプル追加するかも)

```VB:
Sub DataBase_Sample()
    '-------------------------------------------------------------------
    'DB変数定義
    Dim strSQL As String    ' SQL文字列
    Dim cn As Object   ' コネクション
    Dim rs As Object   ' レコードセット
    '-------------------------------------------------------------------
    '接続設定
    Set cn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    'ADOでSQLServerに接続
    With cn
        .Provider = "SQLOLEDB"       'OLE DBプロバイダ
        .ConnectionTimeout = 180     '接続タイムアウト時間 (単位:秒)
        .CommandTimeout = 120        'コマンドタイムアウト時間 (単位:秒)
        .Properties("Data Source").Value = "サーバー名\インスタンス名"
        .Properties("Initial Catalog").Value = "データベース名"
        .Properties("User ID").Value = "user"              'アカウント
        .Properties("Password").Value = "password"         'パスワード
'        .Properties("Integrated Security").Value = "SSPI"     'Windows認証を使用する場合
        .CursorLocation = 3 ' クライアントサイドカーソルに変更 → 3にしないとrs.RecordCountが正しく取れない
        .Open
    End With
    '----------------------------------------------------------------------
    'INSERT文
    strSQL = "INSERT INTO [t_Log] ([UserID], [Message], [Status], [created_at])"
    strSQL = strSQL & "VALUES ('625', 'mocho', 'Success', getDate())"
    cn.Execute strSQL
    '----------------------------------------------------------------------
    'SELECT文 (登録・更新)
    strSQL = "SELECT * FROM [TableName] "
    strSQL = strSQL & "WHERE CAST([created_at] as Date) = '" & Format(Now, "yyyy-mm-dd") & "' "
    strSQL = strSQL & "OR [name] = 'Momo' "
    'レコードセットを開く
    'rs.Open strSQL, cn, adOpenKeyset, adLockOptimistic, 1   '参照設定ありの場合、定数が使用可能
    rs.Open strSQL, cn, 1, 3, 1
    'カーソルタイプ   '0:adOpenForwardOnly  '1:adOpenKeyset  2:adOpenDynamic  3:adOpenStatic
    'ロックタイプ     '1:adLockReadOnly  2:adLockPessimistic  3:adLockOptimistic  4:adLockBatchOptimistic
    'オプション       '1:adCmdText
    '----------------------------------------------------------------------
    Debug.Print rs.RecordCount
    If rs.EOF Then
        '新規登録
        rs.AddNew
        rs![name] = "Momo"
        rs![prefecture] = "Fukuoka"
        rs![food] = "Udon"
        rs![created_at] = Now
        rs![updated_at] = Now
        rs.Update
    Else
        '更新
        rs![food] = "Chili Tomato"
        rs![updated_at] = Now
        rs.Update
    End If
    '----------------------------------------------------------------------
    rs.Close
    Set rs = Nothing
End Sub
```


### シートの存在チェック関数
シート名を引数で渡すと、そのシートがブック内に存在するか確認して結果をBooleanで返します。

```VB:
' シートの存在チェック関数
Public Function SheetExists(SheetName As String) As Boolean
    Dim ws As Worksheet
    SheetExists = False
    For Each ws In Worksheets
        If ws.Name = SheetName Then
            SheetExists = True
            Exit For
        End If
    Next ws
End Function
```


## おわりに
何か文句や間違いがあればコメントで教えてください。
（コピペプログラマなのでお手柔らかにお願いします...）