YUKIBEのBLOG

日常のメモ書き

Excel：VBA：ListObject

VBA

参考

テーブル操作の概要（ListObject）｜VBA入門
テーブル操作のVBAコード（ListObject,DataBodyRange）｜VBA入門

テーブル

テーブルに設定

'##############################################################
'第131回.テーブル操作のVBAコード（ListObject,DataBodyRange）
'https://excel-ubara.com/excelvba1/EXCELVBA431.html
'##############################################################
Sub テーブルに設定()
    
    Dim ws As Worksheet
    Set ws = ActiveSheet
    
    Dim tbl As ListObject
    Set tbl = ws.ListObjects.Add(xlSrcRange, ws.Range("B2").CurrentRegion, , xlYes, , "TableStyleLight2")
    
    tbl.Name = "テーブル1"
'    tbl.TableStyle = "TableStyleLight2"

End Sub

テーブルスタイル一覧()

Sub テーブルスタイル一覧()

    Dim tblStyle As TableStyle
    For Each tblStyle In ThisWorkbook.TableStyles
        Debug.Print tblStyle.Name
    Next

End Sub

テーブルの存在確認1

Function テーブルの存在確認1() As Boolean

  テーブルの存在確認1 = False
    
  Dim ws As Worksheet
  Set ws = ActiveSheet
  If ws.ListObjects.Count > 0 Then
      テーブルの存在確認1 = True
      Exit Function
  End If

End Function

Function テーブルの存在確認2() As Boolean
    
  Dim ws As Worksheet
  Set ws = ActiveSheet
  If Not ws.Range("B2").ListObject Is Nothing Then
      テーブルの存在確認2 = True
      Exit Function
  End If

End Function

テーブル名の存在確認1

Function テーブル名の存在確認1( _
                              ByVal sTbName As String _
                              ) As Boolean

  テーブル名の存在確認1 = False
    
  Dim ws As Worksheet
  Set ws = ActiveSheet
  
  Dim objListObj As ListObject
  For Each objListObj In ws.ListObjects
    If objListObj.Name = sTbName Then
      テーブル名の存在確認1 = True
      Exit Function
    End If
  Next objListObj
  
  
End Function

範囲に変換

Sub 範囲に変換()

    Dim ws As Worksheet
    Set ws = ActiveSheet
    Dim tbl As ListObject
    Set tbl = ws.ListObjects("テーブル1")
    'Set tbl = ws.ListObjects(1)
    'Set tbl = ws.Range("B2").ListObject
    tbl.TableStyle = ""
    tbl.Unlist

End Sub

範囲に変換_シート全て

Sub 範囲に変換_シート全て()
    Dim ws As Worksheet
    Set ws = ActiveSheet
    Dim tbl As ListObject
    For Each tbl In ws.ListObjects
        tbl.TableStyle = ""
        tbl.Unlist
    Next
End Sub

テーブルの範囲を再設定

Sub テーブルの範囲を再設定()
    Dim ws As Worksheet
    Set ws = ActiveSheet
    Dim tbl As ListObject
    Set tbl = ws.Range("B2").ListObject
    tbl.Resize ws.Range("B2").CurrentRegion
End Sub

セルに値を入れる

Sub セルに値を入れる()

    Dim ws As Worksheet
    Set ws = ActiveSheet
    Dim tbl As ListObject
    Set tbl = ws.ListObjects("テーブル1")
    
    tbl.ListRows(4).Range(2) = "あ"         '// DataBody 4行目、列2
    tbl.ListColumns("列2").Range(6) = "い"  '// 列2、HDR含め6番目
    tbl.ListRows(6).Range(tbl.ListColumns("列2").Index) = "う"
    
End Sub

セルの数式変更

' @は同じ行を意味していますので、[@列1]は、「列1」の同じ行の値になります。
Sub セルの数式変更()

    Dim ws As Worksheet
    Set ws = ActiveSheet
    Dim tbl As ListObject
    Set tbl = ws.ListObjects("テーブル1")
    tbl.ListRows(4).Range(3) = "=[@列1]+[@列2]"
    tbl.ListColumns("列3").Range(6) = "=[@列1]+[@列2]"
    tbl.ListRows(3).Range(tbl.ListColumns("列3").Index) = "=[@列1]+[@列2]"
    
End Sub

HeaderRow

列リスト

'###########################################
'#  HeadreRow
'###########################################
Sub 列リスト()
    Dim ws As Worksheet:    Set ws = ActiveSheet
    Dim tbl As ListObject:    Set tbl = ws.ListObjects("テーブル1")
    
    Dim v
    
    '// HeaderRowRange
    For Each v In tbl.HeaderRowRange
      Debug.Print v.Text  '// Rangeだから「.Value」「.Text」
    Next v
    
    
    '// ListColumns
    Dim dicNameIdx As Object
    Set dicNameIdx = CreateObject("Scripting.Dictionary")
    
    For Each v In tbl.ListColumns
      dicNameIdx.Add v.Name, v.Index
    Next v
    If dicNameIdx.Exists("列3") Then
      Debug.Print dicNameIdx.Item("列3")  '// 列3のIndex
    End If
    Debug.Print tbl.ListColumns("列3").Index
    
End Sub

列リスト_subDic / retDic

Sub 列リスト_subDic()

  Dim dic As Dictionary
  Set dic = 列リスト_retDic("テーブル1")
  If dic Is Nothing Then Exit Sub
  
    If dic.Exists("列3") Then
      Debug.Print dic.Item("列3")(0)  '// 列3のIndex
      Debug.Print dic.Item("列3")(1)  '// 列3のAddress
    End If
  
End Sub

Function 列リスト_retDic( _
                        ByVal sTbName As String _
                        ) As Dictionary

  If Not テーブル名の存在確認1(sTbName) Then Exit Function
  
  Dim ws As Worksheet:    Set ws = ActiveSheet
  Dim tbl As ListObject:  Set tbl = ws.ListObjects(sTbName)
  
  Dim v
  '// HeaderRowRange(アドレスはWsRange)
  For Each v In tbl.HeaderRowRange
    Debug.Print v.Text, v.Address(False, False) '// Rangeだから「.Value」「.Text」
  Next v
  
  
  '// ListColumns
  Set 列リスト_retDic = New Dictionary
  For Each v In tbl.ListColumns
    列リスト_retDic.Add v.Name, Array(v.Index, v.Range(1).Address(False, False))
  Next v
    
    
End Function

DataBody

クリア（列・行）

列のクリア

Sub 列のクリア()
    Dim ws As Worksheet
    Set ws = ActiveSheet
    Dim tbl As ListObject
    Set tbl = ws.ListObjects("テーブル1")
    Dim col As Long
    col = tbl.ListColumns("列3").Index
    tbl.DataBodyRange.Columns(col).ClearContents
End Sub

行のクリア

Sub 行のクリア()
    Dim ws As Worksheet
    Set ws = ActiveSheet
    Dim tbl As ListObject
    Set tbl = ws.ListObjects("テーブル1")
    Dim col As Long
    tbl.ListRows(5).Range.ClearContents
End Sub

列の数式設定

Sub 列の数式設定()
    Dim ws As Worksheet
    Set ws = ActiveSheet
    Dim tbl As ListObject
    Set tbl = ws.ListObjects("テーブル1")
    Dim col As Long
    col = tbl.ListColumns("列3").Index
    tbl.DataBodyRange.Columns(col) = "=[@列1]+[@列2]"
End Sub

列の数式設定_個別1

Sub 列の数式設定_個別1()
    Dim ws As Worksheet
    Set ws = ActiveSheet
    Dim tbl As ListObject
    Set tbl = ws.ListObjects("テーブル1")
    Dim col As Long
    col = tbl.ListColumns("列3").Index
    Dim myRange As Range
    For Each myRange In tbl.DataBodyRange.Columns(col)
        myRange = "=[@列1]+[@列2]"
    Next
End Sub

列の数式設定_個別2

Sub 列の数式設定_個別2()
    Dim ws As Worksheet
    Set ws = ActiveSheet
    Dim tbl As ListObject
    Set tbl = ws.ListObjects("テーブル1")
    Dim col As Long
    col = tbl.ListColumns("列3").Index
    Dim myRow As ListRow
    For Each myRow In tbl.ListRows
        myRow.Range(col) = "=[@列1]+[@列2]"
    Next
End Sub

挿入（行・列）

行挿入

'ListRowsオブジェクト.Add (Position, always insert)
'最終行の下に追加する場合は､Positionを省略してください｡
'AlwaysInsert
'テーブルの最終行より下のセルのデータを移動するかどうかを指定します｡
'Trueの場合､表の下のセルは1行下に移動します｡
'Falseの場合､テーブルの下の行が空の場合は､テーブルが拡張されて､その行を使用するようになります｡ただし､テーブルの下の行にデータが含まれている場合､それらのセルは新しい行が挿入されるときにシフトされます｡
'省略時はTrueになります｡
Sub 行挿入()
    Dim ws As Worksheet
    Set ws = ActiveSheet
    Dim tbl As ListObject
    Set tbl = ws.ListObjects("テーブル1")
    tbl.ListRows.Add Position:=5
End Sub

列挿入

'Position:=の直前列に追加されます。
'最後列に追加する場合は、Position:=を省略してください。''
Sub 列挿入()
    Dim ws As Worksheet
    Set ws = ActiveSheet
    Dim tbl As ListObject
    Set tbl = ws.ListObjects("テーブル1")
    tbl.ListColumns.Add Position:=3
    tbl.HeaderRowRange(3) = "追加列"
End Sub

列削除

Sub 列削除()
    Dim ws As Worksheet
    Set ws = ActiveSheet
    Dim tbl As ListObject
    Set tbl = ws.ListObjects("テーブル1")
    tbl.ListColumns(3).Delete
End Sub

オートフィルター

Sub オートフィルター()
    Dim ws As Worksheet
    Set ws = ActiveSheet
    Dim tbl As ListObject
    Set tbl = ws.ListObjects("テーブル1")
    With tbl
        With .DataBodyRange
            .AutoFilter Field:=tbl.ListColumns("列1").Index, Criteria1:=4
            If tbl.Range.SpecialCells(xlCellTypeVisible).Rows.Count > 1 Then
                .EntireRow.Delete
                'Application.DisplayAlerts = False
                '.Delete
            End If
        End With
        .AutoFilter.ShowAllData
    End With
End Sub

ソート

Sub ソート()
    Dim ws As Worksheet
    Set ws = ActiveSheet
    Dim tbl As ListObject
    Set tbl = ws.ListObjects("テーブル1")
    With tbl
        With .Sort
            .SortFields.Clear
            .SortFields.Add Key:=tbl.HeaderRowRange(1), _
                     SortOn:=xlSortOnValues, _
                     Order:=xlDescending
            .Header = xlYes
            .Apply
        End With
    End With
End Sub

集計行挿入

Sub 集計行挿入()
    Dim ws As Worksheet
    Set ws = ActiveSheet
    Dim tbl As ListObject
    Set tbl = ws.ListObjects("テーブル1")
    tbl.ShowTotals = True
    Dim col As ListColumn
    For Each col In tbl.ListColumns
        col.TotalsCalculation = xlTotalsCalculationSum
    Next
End Sub

集計行削除

Sub 集計行削除()
    Dim ws As Worksheet
    Set ws = ActiveSheet
    Dim tbl As ListObject
    Set tbl = ws.ListObjects("テーブル1")
    tbl.TotalsRowRange.Delete
End Sub

集計行非表示

Sub 集計行非表示()
    ActiveSheet.ListObjects("テーブル1").ShowTotals = False
End Sub

右端に集計列追加

Sub 右端に集計列追加()
    Dim ws As Worksheet
    Set ws = ActiveSheet
    Dim tbl As ListObject
    Set tbl = ws.ListObjects("テーブル1")
    With tbl.HeaderRowRange
        .Resize(1, 1).Offset(, .Count) = "集計列"
        .Resize(1, 1).Offset(1, .Count) = "=SUM([@[" & .Item(2) & "]:[" & .Item(6) & "]])"
    End With
End Sub

新しい行列を含めない

'VBAで一時的にこれを停止して、セルに値をいれてから元に戻しておくVBAになります。
Sub 新しい行列を含めない()
    Dim ws As Worksheet
    Set ws = ActiveSheet
    Dim tbl As ListObject
    Set tbl = ws.ListObjects("テーブル1")
    Application.AutoCorrect.AutoExpandListRange = False
    Range("H6") = 1
    Application.AutoCorrect.AutoExpandListRange = True
End Sub

テーブル全件処理

'第142回.テーブル全件処理とデータ最終行（ListObject,DataBodyRange）
'https://excel-ubara.com/excelvba1/EXCELVBA442.html
Sub テーブル全件処理()
    Dim ws As Worksheet
    Set ws = ActiveSheet
    Dim tbl As ListObject
    Set tbl = ws.ListObjects("テーブル1")
  
    Dim c1 As Long, c2 As Long, c3 As Long
    c1 = tbl.ListColumns("列1").Index
    c2 = tbl.ListColumns("列2").Index
    c3 = tbl.ListColumns("列3").Index
  
    Dim i As Long
    With tbl.DataBodyRange
        For i = 1 To .Rows.Count
            .Cells(i, c3).Value = .Cells(i, c1).Value / .Cells(i, c2).Value
        Next
    End With
End Sub

テーブルの特定列のデータ最終行まで

Function テーブルの特定列のデータ最終行まで()
    Dim ws As Worksheet
    Set ws = ActiveSheet
    Dim tbl As ListObject
    Set tbl = ws.ListObjects("テーブル1")
  
    Dim c1 As Long, c2 As Long, c3 As Long
    c1 = tbl.ListColumns("列1").Index
    c2 = tbl.ListColumns("列2").Index
    c3 = tbl.ListColumns("列3").Index
  
    Dim lastRow As Long
    lastRow = TableLastRow(tbl, tbl.ListColumns("列1").Index)

    Dim i As Long
    With tbl.DataBodyRange
        For i = 1 To lastRow
            .Cells(i, c3).Value = .Cells(i, c1).Value + .Cells(i, c2).Value
        Next
    End With
End Function

Function TableLastRow(ByVal tbl As ListObject, ByVal argCol As Variant) As Long
    '列名と列Indexの両対応
    Dim col As Long
    If IsNumeric(argCol) Then
        col = argCol
    Else
        col = tbl.ListColumns(argCol).Index
    End If
  
    'テーブルの下から順にデータの入っている行を探す
    Dim i As Long
    With tbl.DataBodyRange
        For i = .Rows.Count To 1 Step -1
            If .Cells(i, col).Value <> "" Then
                TableLastRow = i
                Exit Function
            End If
        Next
    End With
End Function

Outlook：VBA

Outlook

【初心者向け】Outlook マクロ（VBA）を使って時短しよう！
Outlook VBAのオブジェクトについて - エク短｜Extan.jp
Inspector.CurrentItem プロパティ (Outlook) | Microsoft Learn


Sub GetAppActInsCurrItem()

  Dim objIns As Inspector
  Dim objItem As Object
  
  Set objIns = Application.ActiveInspector
  If objIns Is Nothing Then Exit Sub
  
  Set objItem = objIns.CurrentItem   '今開いているメールのMailItemオブジェクトを取得

  Debug.Print objItem.SendUsingAccount.SmtpAddress
  Debug.Print objItem.SenderName
  Debug.Print objItem.To
  Debug.Print objItem.CC
  Debug.Print objItem.BCC
  Debug.Print objItem.Body

End Sub

Excel：ショートカット：

Excel

参考

Excelショートカットキー一覧｜Excelリファレンス

ファイル

ファイル
ファイルを開く Ctrl + O
ファイルの新規作成 Ctrl + N
ファイルを開く Ctrl + F12
上書き保存する Ctrl + S
上書き保存する Shift + F12
上書き保存する Alt + Shift + F2
名前を付けて保存する F12
名前を付けて保存する Alt + F2

ウインドウ

シート

印刷

コピー/貼付

検索/置換

選択

移動

挿入/削除

挿入/削除
選択範囲のセルを削除する Ctrl + -
セルを挿入する Ctrl + Shift + ; (+)
新しいコメント（コメントの挿入） Ctrl + Shift + F2

元に戻す/繰り返す

入力

編集

書式

表示/非表示

関数

再計算

名前定義/テーブル

フィルター

マクロ

その他

Excel：VBA：セル（Range）：選択、特定方法

VBA Excel

参考

VBA セルを選択する (Range.Select, Selection)

Activate / Select

VBA 似た者SelectとActivateの違いを最速に理解 | 小さな書店の経営術
VBAのSelectとActivateの違い ｜ Excel作業をVBAで効率化

選択、特定方法

Sub Cell__Sample()

'「Activate」ただ一つのものを選択する時に使う
'　　選択範囲が指定範囲内ならば、選択範囲を変更せず、指定範囲内の開始１セルをActive
'　　選択範囲が指定範囲外ならば、選択範囲を変更して、指定範囲内の開始１セルをActive
'　　選択範囲を変更したくない場合は、範囲内で「Activate」
'    Activecell
  
'「Select」範囲を選択する時に使う
'　　選択範囲をActiveにして、開始セルをActive
'    Selection

 
  Cells.Activate
  Range("B2:D4").Activate '選択範囲が変わらない(ActiveCellは「B2」)

  'セルを選択する
  Range("B1").Activate  '選択範囲が変わらない(ActiveCellは「B1」)
  
'-----------------------------------------------------------------
  '// シートがアクティブになっていないとエラー
  Worksheets("Sheet2").Range("A3").Select   '//  エラー
  Worksheets("Sheet2").Range("A3").Activate '//  エラー
  
  '// 参考：シート選択
  '// BOOKがアクティブになっていなくても「Active」は可能
  Workbooks("Book2").Worksheets("Sheet2").Select    '//  エラー
  Workbooks("Book2").Worksheets("Sheet2").Activate  '//  可能
'-----------------------------------------------------------------
  
  '単一セルを選択する
  Cells(2, 1).Select  ' A2
  Cells(1, "B").Select ' B1

  'セルを範囲選択
  Range("A1:B2").Select
  Range("A1", "B2").Select

  'セルをアクティブにする(選択範囲変更なし)
  Range("A2").Activate

  '離れたセルを範囲選択
  Range("E1, G2").Activate  '(選択範囲変更)
  Range("A1, C2").Select

  'Select と Activate の違い
  'Select：選択範囲がセル「C3」のみになります。
  Range("B2:D4").Select
  Range("C3").Select

  'Activate：選択範囲を維持したままセル「C3」をアクティブにします。
  Range("B2:D4").Activate
  Range("C3").Activate
  Range("C10").Activate '範囲から外れると、選択範囲はクリア

  Range("B2:D4").Activate
  Selection = "dd"
  
End Sub

Excel：VBA：セル（Range）

VBA Excel

参考

VBA セルを選択する (Range.Select, Selection)

Activate / Select

VBA 似た者SelectとActivateの違いを最速に理解 | 小さな書店の経営術
VBAのSelectとActivateの違い ｜ Excel作業をVBAで効率化

選択、特定方法

Sub Cell__Sample()

'「Activate」ただ一つのものを選択する時に使う
'　　選択範囲が指定範囲内ならば、選択範囲を変更せず、指定範囲内の開始１セルをActive
'　　選択範囲が指定範囲外ならば、選択範囲を変更して、指定範囲内の開始１セルをActive
'　　選択範囲を変更したくない場合は、範囲内で「Activate」
'    Activecell
  
'「Select」範囲を選択する時に使う
'　　選択範囲をActiveにして、開始セルをActive
'    Selection

 
  Cells.Activate
  Range("B2:D4").Activate '選択範囲が変わらない(ActiveCellは「B2」)

  'セルを選択する
  Range("B1").Activate  '選択範囲が変わらない(ActiveCellは「B1」)
  
'-----------------------------------------------------------------
  '// シートがアクティブになっていないとエラー
  Worksheets("Sheet2").Range("A3").Select   '//  エラー
  Worksheets("Sheet2").Range("A3").Activate '//  エラー
  
  '// 参考：シート選択
  '// BOOKがアクティブになっていなくても「Active」は可能
  Workbooks("Book2").Worksheets("Sheet2").Select    '//  エラー
  Workbooks("Book2").Worksheets("Sheet2").Activate  '//  可能
'-----------------------------------------------------------------
  
  '単一セルを選択する
  Cells(2, 1).Select  ' A2
  Cells(1, "B").Select ' B1

  'セルを範囲選択
  Range("A1:B2").Select
  Range("A1", "B2").Select

  'セルをアクティブにする(選択範囲変更なし)
  Range("A2").Activate

  '離れたセルを範囲選択
  Range("E1, G2").Activate  '(選択範囲変更)
  Range("A1, C2").Select

  'Select と Activate の違い
  'Select：選択範囲がセル「C3」のみになります。
  Range("B2:D4").Select
  Range("C3").Select

  'Activate：選択範囲を維持したままセル「C3」をアクティブにします。
  Range("B2:D4").Activate
  Range("C3").Activate
  Range("C10").Activate '範囲から外れると、選択範囲はクリア

  Range("B2:D4").Activate
  Selection = "dd"
  
End Sub

Excel：VBA：ブック：開いているブック

Excel VBA

aTEST_開いているブック

Sub aTEST_開いているブック()

  Dim vFE

  Dim lstWbName As Collection:  Set lstWbName = New Collection
  Set lstWbName = getWbOpenedName_lst
  For Each vFE In lstWbName
    Debug.Print vFE
  Next vFE

  Dim dicWbName As Dictionary:  Set dicWbName = New Dictionary
  Set dicWbName = getWbOpenedName_dic
  For Each vFE In dicWbName
    Debug.Print vFE
  Next vFE

  Dim vArr As Variant
  vArr = getWbOpenedName_vArr
  For Each vFE In vArr
    Debug.Print vFE
  Next vFE

  Dim sArr() As String
  sArr = getWbOpenedName_sArr
  For Each vFE In sArr
    Debug.Print vFE
  Next vFE

End Sub

開いているブックリスト_Collection

'*****************************************************************
'* 開いているブックリスト
'*
'* ARG01
'* ARG02
'*
'* 戻り値
'*
'* NOTE
'*
'*****************************************************************
Public Function getWbOpenedName_lst() As Collection

  Dim colc As Collection
  Set colc = New Collection
  
  Dim wb As Workbook
  For Each wb In Workbooks
    colc.Add wb.Name
  Next wb
  
  Set getWbOpenedName_lst = colc

End Function

開いているブックリスト_dictionary

'*****************************************************************
'* 開いているブックリスト
'*
'* ARG01
'* ARG02
'*
'* 戻り値
'*
'* NOTE
'*
'*****************************************************************
Public Function getWbOpenedName_dic() As Dictionary

  Dim dic As Dictionary
  Set dic = New Dictionary
  
  Dim wb As Workbook
  For Each wb In Workbooks
    dic.Add wb.Name, ""
  Next wb
  
  Set getWbOpenedName_dic = dic

End Function

開いているブックリスト_Array Variant


'*****************************************************************
'* 開いているブックリスト
'*
'* ARG01
'* ARG02
'*
'* 戻り値
'*
'* NOTE
'*
'*****************************************************************
Public Function getWbOpenedName_vArr() As Variant

  Dim i As Long
  Dim vArr
    
  Dim wb As Workbook
  For Each wb In Workbooks
    If i = 0 Then
      ReDim vArr(i)
    Else
      ReDim Preserve vArr(i)
    End If
    vArr(i) = wb.Name
    i = i + 1
  Next wb
  
  getWbOpenedName_vArr = vArr

End Function

開いているブックリスト_Array String

'*****************************************************************
'* 開いているブックリスト
'*
'* ARG01
'* ARG02
'*
'* 戻り値
'*
'* NOTE
'*
'*****************************************************************
Public Function getWbOpenedName_sArr() As String()

  Dim i As Long
  Dim sArr() As String
  ReDim sArr(Workbooks.Count - 1) As String
    
  Dim wb As Workbook
  For Each wb In Workbooks
    sArr(i) = wb.Name
    i = i + 1
  Next wb
  
  getWbOpenedName_sArr = sArr

End Function

Excel：VBA：ブック

VBA Excel

参考

VBA 新規作成ブックとシート。アクティブ状態でやっておくこと | 小さな書店の経営術

Wb Close

'*****************************************************************
'* Wb Close
'*
'* ARG01
'* ARG02
'*
'* 戻り値
'*
'* NOTE
'*  Sub Close([SaveChanges], [Filename], [RouteWorkbook])
'*
'*****************************************************************
Sub setWbClose( _
                wb As Workbook, _
                Optional bSaveChanges As Boolean = True _
                )

    wb.Close SaveChanges:=bSaveChanges

End Sub