この記事は何
Excelマクロ(VBAコード)のサンプル集です。
VBAのコーディングに時間を割くのは勿体ないので、よく使うであろうコードをまとめました。
随時追加・修正していきます。
2022/10/25追記：VBAの現場から退いたので更新することはもう無いと思います。
基本編
メッセージを表示する (MsgBox)
備考：第2引数は「+」で追加して連結する
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
ログ出力 (Debug.Print)
イミディエイトウィンドウ内に出力される。
💡イミディエイトウィンドウを表示する設定にしておきましょう。
Debug.Print "ログだよ～(o・∇・o)"
最終行・最終列の取得
格納する変数はInteger型にしてしまうと32,767行以上でオーバーフローするので注意！
'最終行・最終列の取得
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行目）
書式設定
'セルの結合
Range(Cells(1, 1), Cells(2, 1)).Merge '縦2セル
Range(Cells(3, 1), Cells(3, 3)).Merge '横3セル
'表示形式
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
'背景色の設定
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
'グラデーション設定
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
'ハイパーリンク
With ThisWorkbook.Worksheets(1)
.Hyperlinks.Add Anchor:=.Cells(10, 4), _
Address:="https://www.yahoo.co.jp/"
End With
'行の高さ
Rows("1:3").RowHeight = 15 '1～3行目 高さ15
'列の幅
Range(Columns(3), Columns(5)).ColumnWidth = 12 '3～5列目 幅12
'ウィンドウ枠の固定
With ThisWorkbook.Worksheets(1)
.Activate
.Range("B3").Select
ActiveWindow.FreezePanes = True
End With
Select Case文
意外と記法を忘れやすい。
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）
初期値あり、キャンセルボタン処理も対応
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
よく使う文の組み合わせ
新規ブックを作成し、各種書式設定を行う
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
ブックオープン時に自動実行
※標準モジュールに書く場合、他のブックからオープンされると実行されないので注意。
標準モジュール
Private Sub Auto_Open()
MsgBox "開かれました!"
End Sub
▼こちらは必ず実行される
ThisWorkbook
Private Sub Workbook_Open()
MsgBox "開かれました!"
End Sub
アドイン形式（.xlam）の自動実行について
VBA内でオートメーションで別プロセスのExcelを立ち上げた場合、xlamファイルのアドインは読み込まれない。Auto_Openも無効。
Excel2010で新規Excel立ち上げると新プロセスとして起動(xlamのAuto_Openがここで実行される)
Excel2013以降で新規Excel立ち上げると既存プロセスの別ブックとして起動(xlamのAuto_Openは実行されない)
描画停止で処理高速化
セルに変更を加える処理をループで回す場合に、描画を止めると早くなるという定石がある。
以下コード、時間計測のおまけ付き
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."
読み取り専用に変更
If ThisWorkbook.ReadOnly = False Then '現在の設定が読み取り専用でないかチェック
ThisWorkbook.ChangeFileAccess Mode:=xlReadOnly '読み取り専用に変更
End If
'逆に書き込みを許すとき↓
ThisWorkbook.ChangeFileAccess (xlReadWrite)
参照設定について
CreateObjectを使うと参照設定する必要がなくなる⇒遅延バインディング
（参照設定はブック毎に個別設定が必要で面倒）
「ツール」→「参照設定」で必要なものにチェックを付ける。
⇒事前バインディング
ただし、遅延バインディングは各種定数が自動補完されず、数値を直で入力する必要がある。
例：adOpenKeyset → 1
ファイル操作 (FileSystemObject)
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
MoveFileは同名パスが既に存在するとエラーになるのでFileExistsと組み合わせるのを推奨
UTF-8のテキストファイルを読み込む
VBAはデフォルトではShift_JISしか読めないのでADODB.Streamを利用する。
Dim buf As String
With CreateObject("ADODB.Stream")
.Charset = "UTF-8"
.Open
.LoadFromFile "ファイルパス"
buf = .ReadText '全データがbufに入る
.Close
End With
HTTPリクエストで文字列を取得
取得した値はベタのHTMLなのでスクレイピング用途には加工が必要
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とかも使える(後日サンプル追加するかも)
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で返します。
' シートの存在チェック関数
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
おわりに
何か文句や間違いがあればコメントで教えてください。
（コピペプログラマなのでお手柔らかにお願いします...）