Excel：VBA：ListObject

参考

テーブル操作の概要（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