はじめに
Excel 2019 on Windows10 を対象としています。
公開されている情報を参照して、プライベートの時間に整理したものです。
順次追記予定です。
関連記事
元に戻す／やり直しへの対応
Excel では VBA マクロの各種関数でシート内容を加工してしまうと、マクロ実行後に元に戻す／やり直しの履歴がリセットされてしまい、マクロ実行前の状態に戻せなくなることがあります。このセクションでは、履歴を維持したい場合の対応方法と注意点について記載します。
- SendKeys によりショートカットキーを実行した場合には、元に戻す／やり直しの履歴が維持されるため、シート内容を加工する処理には SendKeys を用いるとよい
- マクロ実行中に SendKeys の操作結果を反映するためには DoEvents を2回実行する。SendKeys の Wait オプションは有効に機能しない。DoEvents を3回以上実行すると履歴がリセットされる場合がある。サブルーチンの最初に DoEvents を実行した場合は挙動がおかしくなる。これらの条件は環境に依存しているかもしれない
- Application.ScreenUpdating や Application.CutCopyMode を変更すると、同様に履歴がリセットされる場合があるので、履歴を維持したい場合は動作確認をするか、なるべく変更を避ける
- ボタンを連続クリックすると誤動作する場合があるが、VBA では厳密な再入防止はできないので、時間間隔をあけて操作してもらう
- 参考：SendKeys ステートメント
Public Sub 次の行を挿入()
SendKeys "{DOWN}"
DoEvents
DoEvents
Selection.EntireRow.Select
SendKeys "^{+}"
DoEvents
DoEvents
End Sub
- VBAによるセルの値変更を伴う処理では、SendKeys の結果が反映されるタイミングと値変更のタイミングがずれてしまうことがあるので、元に戻せなくなることを許容して、各種関数での加工をすることになる
- 元に戻せない操作を伴う場合は、事前に確認メッセージを表示するとよい
Public Sub 次の行を挿入2()
' 元に戻すことができなくなることの確認をする
If MsgBox("元に戻す操作はできませんが、実行しますか", vbOKCancel, "次の行を挿入2") = vbCancel Then
Exit Sub
End If
Selection.EntireRow.Offset(1, 0).Insert ' 次の行を挿入する
Selection.EntireRow.AutoFit ' 行幅を自動調整する
End Sub
選択中セルの操作
Selection により選択中セルの Range オブジェクトを取得して操作できます。
' 選択中でなければ Nothing になっている
If Selection Is Nothing Then
Exit Sub
End If
' アドレスを取得する
' 例えば、単一セル選択時は"$A$1"、複数セル選択時は"$A$1:$C$3"となる
Debug.Print Selection.Address
' 選択範囲の各セルに対して繰り返す
Dim cell As Variant ' セル
For Each cell In Selection
Debug.Print cell.Address
Next
' 選択範囲の各行に対して繰り返す
Dim row As Variant
For Each row In Selection.rows
Debug.Print "ROW:" & row.Address
For Each cell In row.Cells
Debug.Print cell.Address
Next
Next
' 選択範囲の左上のセルのみ選択する
' Cells(行, 列)により選択範囲における相対位置を指定して単一セルを選択できる
' 左上が(1, 1)となる
Selection.Cells(1, 1).Select
' テキストを取得する
Debug.Print Selection.Cells(1, 1).Text
Debug.Print Selection.Cells(1, 1) ' 受け取り側が String 型であれば .Text は省略できます
' セルの値を設定する
Selection.Cells(1, 1) = "ABC"
' セル位置はインデクスでも指定できる。例えば2行3列を選択時は下記に対応する
' | 1 | 2 | 3 |
' | 4 | 5 | 6 |
' セル位置を指定しない場合は、複数セル選択時にNullになる
Debug.Print Selection(1)
' 元の選択範囲を保持する。Setが必要
Dim org As Range ' 元の選択範囲
Set org = Selection
' 次の行を選択する
' Offset(行, 列)により相対位置を指定してずらし、Selectにより選択できる
' このとき、元の選択範囲のサイズが維持されるが、結合セルがあると選択範囲が変わる
' 元に戻す／やり直しの履歴は維持されるが、Selectによる選択の操作は履歴に含まれない
Selection.Offset(1, 0).Select
' 行全体を選択する
Selection.EntireRow.Select
' 列全体を選択する
Selection.EntireColumn.Select
' 行全体をコピーして次の行に挿入する
' このとき、元に戻す／やり直しの履歴は維持される
Selection.EntireRow.Copy
Selection.EntireRow.Offset(1, 0).EntireRow.Select
SendKeys "^{+}"
DoEvents
DoEvents
' 元の選択範囲に戻す
org.Select
使用範囲の選択
ActiveSheet.UsedRange により使用範囲の Range オブジェクトを取得して操作できます。
' 使用範囲を選択する
ActiveSheet.UsedRange.Select
' 使用範囲の右上のセルを選択する
With ActiveSheet.UsedRange
.Cells(1, .Columns.Count).Select
End With
アドレス指定による操作
ActiveSheet.Range によりアドレスを指定して操作できます。
- 参考：Range オブジェクト
' E3セルのテキストを表示
Debug.Print ActiveSheet.Range("E3")
' E3:E5を範囲選択する
ActiveSheet.Range("E3:E5").Select
重なる範囲の取得
Intersect を用いて範囲のAND条件を求められます。
' 同じ行の別の列を選択
Debug.Print Intersect(Range("N10").EntireRow, Range("L:L")).Address ' "$L$10"が表示される
' 全行を対象にすると時間がかかるので、使用範囲のE列に対してのみ処理することで、処理時間を短縮する
Dim cell As Range ' セル
For Each cell In Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("E:E"))
Debug.Print cell.Address
Next
クリップボードの操作
下記の関数を作成して呼び出すことでテキストをコピー／取得できます。
- 同一モジュールからのみ呼び出す場合は Public → Private にします
- 参考：[VBA]DataObjectを使ったクリップボード操作が上手くいかない場合の対処法
Public Sub SetTextToClipboard(text As String)
' テキストをクリップボードにコピーする
With CreateObject("Forms.TextBox.1")
.text = text
.SelStart = 0
.SelLength = .TextLength
.Copy
End With
End Sub
Public Function GetTextFromClipboard() As String
' クリップボードからテキストを取得する
With CreateObject("Forms.TextBox.1")
.MultiLine = True
If .CanPaste = True Then .Paste
GetTextFromClipboard = .text
End With
End Function
テキストの判定
Like 演算子を活用することで、テキストの判定が容易になります。
- 参考：Like 演算子
' 選択中セルのテキストを取得
Dim text As String ' 選択中セルのテキスト
text = Selection(1)
' テキストにABCが含まれない場合にメッセージを表示して中断する
If Not text Like "*ABC*" Then
MsgBox "ABCを含むセルを選択してください", vbOKOnly, "ABCセルの選択"
Exit Sub
End If
テキストの分割
Split によりテキストを分割できます。
- 参考：Split 関数
' 複数セルをコピーした後に実行すると、イミディエイトウインドウに各セルのテキストを表示する
Dim text As String ' クリップボードから取得したテキスト
Dim rows As Variant ' 行配列
Dim row As Variant ' 行
Dim items As Variant ' 項目配列
Dim item As Variant ' 項目
text = GetTextFromClipboard()
rows = Split(text, vbCrLf)
If UBound(rows) = -1 Then
Debug.Print "改行が含まれていない"
End If
For Each row In rows
items = Split(row, vbTab)
If UBound(items) = -1 Then
Debug.Print "タブが含まれていない"
End If
For Each item In items
Debug.Print item
Next
Next
図形の操作
Shape オブジェクトにより図形を取り扱うことができます。
- 参考：Shape オブジェクト
' 選択中のシートに含まれる各図形に対して繰り返す
Dim shp As Shape ' 図形
For Each shp In ActiveSheet.Shapes
' 図形の種類を表示する
Debug.Print shp.AutoShapeType
' 図形の左側座標と幅を表示する
Debug.Print shp.Left, shp.Width
' 図形にテキストがあれば表示する
If shp.TextFrame2.HasText Then
Debug.Print shp.TextFrame2.TextRange
End If
Next
リストの活用
Collection によるリストを用いて、テキストを保持したり、区切り文字で結合できます。
Private Function JoinList(target As Object, delim As String)
' リスト項目のテキストを結合する
'
' Args:
' - target (Object): 対象リスト＝｛テキスト｝
' - delim (String): 区切り文字
Dim res As String ' 結合結果
Dim text As Variant ' テキスト
For Each text In target
res = IIf(res = "", text, res & delim & text)
Next
JoinList = res
End Function
Public Sub 動作確認()
' 各セルのテキストをカンマ区切りで結合して表示する
Dim cell As Variant ' セル
Dim itemList As New Collection ' 項目リスト
For Each cell In Selection
itemList.Add cell
Next
Debug.Print JoinList(itemList)
End Sub
辞書の活用
Dictionary オブジェクトによる辞書を用いることで、Switch 文を置き換えてスマートに実装できます。
Public Sub 動作確認()
' 対象図形の種類を指定する
Dim targetTypes As Object ' 対象図形タイプ
Set targetTypes = CreateObject("Scripting.Dictionary")
targetTypes.Add msoShapeFlowchartDocument, "ドキュメントを表す図形"
targetTypes.Add msoShapeFlowchartMultidocument, "複数のドキュメントを表す図形"
' 選択中のシートに含まれる対象図形のテキストを表示する
Dim shp As Shape ' 図形
For Each shp In ActiveSheet.Shapes
' 対象図形のみを処理する
If Not targetTypes.Exists(shp.AutoShapeType) Then Goto Next_shp
' 図形にテキストがあれば表示する
If shp.TextFrame2.HasText Then
Debug.Print shp.TextFrame2.TextRange
End If
Next_shp:
Next
End Sub
辞書のソート
VBA にソート処理は用意されていないため、サブルーチンを実装する必要があります。シンプルなコードになるため、選択ソートアルゴリズムがお勧めです。
Private Sub Sort(ByRef pvarArray As Variant)
' 配列をソートする
'
' Args:
' - pvarArray (Variant): ソート対象の配列
Dim i As Long
Dim j As Long
Dim iMin As Long
Dim iMax As Long
Dim varSwap As Variant
iMin = LBound(pvarArray)
iMax = UBound(pvarArray)
For i = iMin To iMax - 1
iMin = i
For j = (i + 1) To iMax
If pvarArray(j) < pvarArray(iMin) Then iMin = j
Next
varSwap = pvarArray(i)
pvarArray(i) = pvarArray(iMin)
pvarArray(iMin) = varSwap
Next
End Sub
Public Sub 動作確認()
' 対象図形の種類を指定する
Dim targetTypes As Object ' 対象図形タイプ
Set targetTypes = CreateObject("Scripting.Dictionary")
targetTypes.Add msoShapeFlowchartDocument, "ドキュメントを表す図形"
targetTypes.Add msoShapeFlowchartMultidocument, "複数のドキュメントを表す図形"
' 対象図形の値順にソートして表示する
Dim indexList As Variant
indexList = targetTypes.keys
Sort indexList
For Each index In indexList
Debug.Print index, targetTypes.Item(index)
Next
End Sub
テキストを含むセルの検索
Find, FindNext によりセルを検索できます。
Private Function FindText(target As Range, text As String, Optional LookAt As Variant = xlWhole) As Collection
' 対象範囲からテキストを含むセルを検索する
'
' Args:
' - target (Range): 対象範囲
' - text (String): テキスト
' - LookAt (Variant): 検索条件＝完全一致(xlWhole)｜部分一致(xlPart)、省略時は 完全一致(xlWhole)
'
' Returns:
' - foundList (Collection): 検索結果リスト＝｛検索結果｝
Dim firstAddress As String ' 最初の検索結果のアドレス
Dim found As Range ' 検索結果
Dim foundList As New Collection ' 検索結果リスト
' 対象範囲からテキストを含むセルを検索する
Set found = target.Find(text, LookIn:=xlValues, LookAt:=LookAt)
If Not found Is Nothing Then
firstAddress = found.Address
Do
foundList.Add found
Set found = target.FindNext(found)
Loop While Not found Is Nothing And found.Address <> firstAddress
End If
' 検索結果リストを返す
Set FindText = foundList
End Function
Public Sub 動作確認()
' C列からテキストを検索してアドレスを表示する
Dim found As Variant ' 検索結果
For Each found In FindText(Range("C:C"), "テキスト")
Debug.Print found.Address
Next
End Sub
合計の計算
WorksheetFunction.Sum により指定範囲の合計を計算できます。
Debug.Print WorksheetFunction.Sum(Range("H6:I6"))
ファイルの選択
Application.GetOpenFilename によりファイルを選択できます。
' ファイルを選択する
Dim path As String ' パス名
path = Application.GetOpenFilename(Title:="ファイルを選択")
If path = "False" Then
Exit Sub ' 未選択のため中断
End If
フォルダの選択
Application.FileDialog によりフォルダを選択できます。
' この変数定義はモジュールファイルの先頭（他の関数定義より前）に記述しないと正しく認識されない
Private 出力先を選択_LastOutdir As String ' 前回選択した出力先ディレクトリ
Public Sub 出力先を選択()
Dim outdir As String ' 出力先ディレクトリ
' 出力先ディレクトリを選択する
' もし前回選択していればその結果を用いる
outdir = 出力先を選択_LastOutdir
If outdir = "" Then
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "出力先ディレクトリを選択"
If .Show = False Then
Exit Sub ' 未選択のため中断
End If
outdir = .SelectedItems(1)
End With
Else
出力先を選択_LastOutdir = outdir
End If
End Sub
パス名の加工
Dir により存在するファイルのファイル名部分のみを抽出できます。
- 参考：Dir 関数
' tmpl に含まれる "-テンプレート" の部分を model に置き換えて、
' ディレクトリを outdir に置き換える
path = outdir & "\" & Replace(Dir(tmpl), "-テンプレート", "-" & model)
リンクの作成
ActiveSheet.Hyperlinks.Add により、選択中のシートにリンクを作成できます。
' 選択中のセルに path へのリンクを追加して「●」を表示する
ActiveSheet.Hyperlinks.Add Anchor:=Selection(1), Address:=path, TextToDisplay:="●"
リンクの取得
Hyperlinks オブジェクトからリンクの情報を参照して取得できます。
' 選択セルにリンクがあれば表示する
If Selection(1).Hyperlinks.Count <> 0 Then
Debug.Print ActiveWorkbook.path & "\" & Selection(1).Hyperlinks(1).Address
End If
コメントの作成
Range.AddComment によりコメントを作成できます。
' 選択セルにコメントを追加する
With Selection(0)
.AddComment "コメント"
With .Comment.Shape
.TextFrame.AutoSize = True
.Height = Application.Max(.Height * .Width / 200, 50)
.Width = 200
End With
End With
セル背景色の変更
ColorIndex プロパティによりセルの背景色を変更できます。
Selection(1).Interior.ColorIndex = 0 ' クリア(0)
Selection(2).Interior.ColorIndex = 44 ' ゴールド(44)
ブックの作成
Workbooks.Add によりブックを作成できます。
' テンプレート tmpl から新たにブックを作成して、加工し、path に保存する
With Workbooks.Add(tmpl)
With .Worksheets("シート名")
.Range("E3") = "E3"
.Range("E4") = "E4"
End With
.SaveAs path
End With
ブックの参照
Workbooks.Open により既存のブックを開くことができます。
' 既存ブックを表示せずに開き、対象セルのテキストを取得する
Application.ScreenUpdating = False
With Workbooks.Open("既存ブックのパス名", ReadOnly:=True)
Windows(.Name).Visible = False
With .Worksheets("シート名")
Debug.Print .Range("E3")
End With
.Close SaveChanges:=False
End With
Application.ScreenUpdating = True
繰り返しのスキップ
Goto を活用して他言語における continue 相当の処理ができます。
- 参考：Goto ステートメント
' 選択範囲の各セルにおいて、リンクが設定されていれば処理をする
Dim cell As Variant
For Each cell In Selection
' リンクが設定されていなければ無視する
' VBAには continue がないので Goto で代用することで、インデントを下げている
If cell.Hyperlinks.Count = 0 Then GoTo Next_cell
' リンクに対して処理する
Debug.Print cell.Hyperlinks(1).Address
Next_cell:
Next
無限ループの中断
Alt + ESC キーを連続入力することで、無限ループを停止できます。