ExcelVBA 　テーブル関連

::: note warn
自分用のメモなので、形は整ってないです。
:::
### テーブルの操作全般。大体のことはここに詰め込んだ
```
**************  標準モジュールのコード   ************************************


Sub AAA()  'テーブル作成

Dim table1 As ListObject  'テーブルのオブジェクト
Dim table2 As ListObject

Worksheets("実験").Cells.Clear
Call CopyData1  'セル範囲をコピペ

Set table1 = ActiveSheet.ListObjects.Add(xlSrcRange, ActiveSheet.Cells(1, 2).CurrentRegion, , xlYes)
'テーブルに設定
table1.Name = "Table1"
table1.TableStyle = "TableStyleLight3"  'テーブルのスタイル


Call CopyData2

Set table2 = ActiveSheet.ListObjects.Add(xlSrcRange, _
  ActiveSheet.Range(Cells(31, 2), Cells(40, 5)), , xlYes)

End Sub


'テーブル追加時に、他のテーブルに重なっている部分が無いか、シートにオートフィルタが設定されていないかを確認する
Sub BBB()
  Dim table1 As ListObject
  
  Worksheets("実験").Cells.Clear
  Call CopyData1

  Set table1 = ReturnTable(ActiveSheet.Cells(1, 2).CurrentRegion)
  '他のテーブルに重なっている部分が無いか、シートにオートフィルタが設定されていないかを確認してから、テーブル追加
  
  If Not table1 Is Nothing Then
    table1.Name = "テーブル1"
    table1.TableStyle = "TableStyleMedium1"
  End If
End Sub




Sub CCC()  '*********  全般  ***********
  Dim table1 As ListObject
  'ここでは、実際にテーブルは設定しない
  
  '※テーブル名は、「デザイン」リボンから指定可能
  '※ブック内に同名のテーブルを複数作成はできないらしい
  
  Debug.Print ActiveSheet.ListObjects("テーブル1").Name
  'シート内にあるテーブルを指定。他のシートのテーブル名を指定するとエラー
  
  'Debug.Print ListObjects("テーブルA").Name  これはエラー
  'Debug.Print ThisWorkbook.ListObjects("テーブルA").Name   これもエラー
  
  Debug.Print ActiveSheet.ListObjects(2).Name
  'テーブルの番号で指定。インデックスは1から始まる
  
  Debug.Print ActiveSheet.ListObjects.Item(2).Name
  'Item番号で指定。インデックスは1から始まる
  
  'シート内の全テーブル名を取得
  Dim tbl As ListObject
  For Each tbl In ActiveSheet.ListObjects
    Debug.Print tbl.Name
  Next tbl

  Debug.Print ActiveSheet.ListObjects.Count  'テーブルの数
  
'  Debug.Print ActiveSheet.ListObjects(1).Rows.Count     これはエラーになる
'  Debug.Print ActiveSheet.ListObjects(1).Columns.Count  これもエラー


  table1.TableStyle = "" 'テーブルのスタイルを消去
  
  table1.Unlist  '通常のセル範囲に戻す。セルの書式はテーブルの時のまま
  
  table1.Delete  'テーブル範囲の値と書式を全てクリア
  
  table1.Resize ActiveSheet.Range(Cells(1, 2), Cells(21, 5))  'テーブル範囲の再設定
  
End Sub


Sub DDD()  '*********  行・列・セルの指定  ****************
Dim table1 As ListObject

  Worksheets("実験").Cells.Clear
  Call CopyData1
  
  Set table1 = ActiveSheet.ListObjects.Add(xlSrcRange, ActiveSheet.Cells(1, 2).CurrentRegion, , xlYes)
  
  table1.ShowTotals = True  '集計行を作成
  
  table1.Range.Select           'テーブルの全範囲を選択
  table1.HeaderRowRange.Select  'テーブルの見出し部分を選択
  table1.DataBodyRange.Select   'テーブルのデータ部分を選択
  table1.TotalsRowRange.Select  'テーブルの集計行部分を選択
  
  Debug.Print table1.ListRows(3).Index
  '行番号で行を指定。インデックスは1から始まる。見出し行は含めないで、データ部分からカウント
  
  Debug.Print table1.ListColumns("列1").Index '見出し行の値で列を指定
  Debug.Print table1.ListColumns(1).Index     '列番号で指定。インデックスは1から始まる
  
  Debug.Print table1.ListRows(3).Range(2).Value
  'データ部分の、3行目の2列目のセルの値を取得。セル番地を指定するならこれがいいだろう
  Debug.Print table1.ListRows(3).Range(table1.ListColumns("列1").Index).Value
  'これでもいい。列の見出しの値で指定できる
  
  Debug.Print table1.ListColumns("列1").Range(4)
  'これでも上と同じになるが、ListColumns("列1")が見出し行もカウントするので、Range(4)になることに注意
  
  
  table1.ListRows(3).Range.Select  'データ部分の3行目全体を選択
  
  table1.DataBodyRange.Columns(3).Select   'データ部分の3列目の全体を選択
  table1.DataBodyRange.Columns(table1.ListColumns("列1").Index).Select
  'データ部分の「列1」の全体を選択
  
  table1.HeaderRowRange.Columns(2).Select  '見出し行の2列目を選択
  
  table1.TotalsRowRange.Columns(3).Select  '集計行の3列目を選択
  table1.TotalsRowRange.Columns(table1.ListColumns("列1").Index).Select  '見出しの値で指定ならこれで
  
  
  Debug.Print table1.DataBodyRange.Rows.Count  'テーブルのデータ部分の行数
  Debug.Print table1.DataBodyRange.Columns.Count  'テーブルの列数
  
  
  'Cells()での指定。これが一番分かりやすいか
  Debug.Print table1.Range.Cells(1, 1)  'テーブル全体の、行1列1のセルの値
  Debug.Print table1.Range.Cells(3, 3)  'テーブル全体の、行3列3のセルの値
  
  Debug.Print table1.HeaderRowRange.Cells(1, 3)  '見出し行の、行1列1
  Debug.Print table1.HeaderRowRange.Cells(2, 3)  'これはエラーにならず、テーブル全体の行2列3になる
  
  Debug.Print table1.DataBodyRange.Cells(1, 3)  'データ部分の、行1列3のセルの値
  Debug.Print table1.DataBodyRange.Cells(5, 4)  'データ部分の、行5列4のセルの値
  
  Debug.Print table1.TotalsRowRange.Cells(1, 3)  '集計行の、行1列3のセルの値
  Debug.Print table1.TotalsRowRange.Cells(2, 2)  'これはエラーにならず、テーブルの外になるようだ
  
End Sub


Sub EEE()  '集計行の設定、削除、非表示　　集計行の数式指定
Dim table1 As ListObject

  Worksheets("実験").Cells.Clear
  Call CopyData3
  
  Set table1 = ActiveSheet.ListObjects.Add(xlSrcRange, ActiveSheet.Cells(1, 2).CurrentRegion, , xlYes)
  
  table1.ShowTotals = True  '集計行を作成

  table1.ListColumns(3).TotalsCalculation = xlTotalsCalculationAverage    '平均
  table1.ListColumns(5).TotalsCalculation = xlTotalsCalculationCount      'データの個数
  table1.ListColumns(7).TotalsCalculation = xlTotalsCalculationCountNums  '数値の個数
  table1.ListColumns(3).TotalsCalculation = xlTotalsCalculationNone       '計算無し
  table1.ListColumns(5).TotalsCalculation = xlTotalsCalculationMax        '最大値
  table1.ListColumns(7).TotalsCalculation = xlTotalsCalculationMin        '最小値
  table1.ListColumns(3).TotalsCalculation = xlTotalsCalculationStdDev     '標準偏差
  table1.ListColumns(5).TotalsCalculation = xlTotalsCalculationSum        '合計
  table1.ListColumns(7).TotalsCalculation = xlTotalsCalculationVar        '分散

'  table1.ListColumns(7).TotalsCalculation = xlTotalsCalculationCustom
'  これはユーザーが数式を設定するらしいが、使わないかな

  table1.TotalsRowRange.Delete  '集計行を削除
  table1.ShowTotals = True
  
  table1.Name = "tableAAAA"
  ActiveSheet.ListObjects("tableAAAA").ShowTotals = False  '集計行を非表示に
  ActiveSheet.ListObjects("tableAAAA").ShowTotals = True   '集計行を表示
  
' ActiveSheet.table1.ShowTotals = False  これはエラーになる

End Sub


Sub FFF()  'セルに値、数式を入れる

  Dim table1 As ListObject
  
  Worksheets("実験").Cells.Clear
  Call CopyData1
  
  Set table1 = ActiveSheet.ListObjects.Add(xlSrcRange, ActiveSheet.Cells(1, 2).CurrentRegion, , xlYes)
  
  table1.ListRows(6).Range(4) = "スイカ"  'データ部分の6行目、4列目のセルの値を設定 .Valueは無しでいい
  table1.ListRows(1).Range(table1.ListColumns("列4").Index) = "2010/12/31"
  
  table1.ListColumns("列1").Range(3) = "AAAA"
  'これは「列1」見出し列のデータ部分の2行目を指定。列指定を先にすると混乱しやすいかも
  
  
  Worksheets("実験").Cells.Clear
  Call CopyData3
  Set table1 = ActiveSheet.ListObjects.Add(xlSrcRange, ActiveSheet.Cells(1, 2).CurrentRegion, , xlYes)
  
  
  '数式の設定
  table1.ListRows(1).Range(10) = "=[@売上1]+[@売上2]"
  ' [@売上1] は、同じ行の売上1列を参照になる
  'よく分からないが、1セルの数式を指定すると、データ部分の列全体に同じ数式が入るらしい
  
  table1.ListColumns(10).Range(3) = "=[@売上1]+[@売上3]"
  'これもデータ部分の列全体に同じ数式が入る
  
  'セルを個別に数式指定するには、以下のようにすればいいはずだが、これでも列全体が最後に入力した数式で統一される
  'Excel2016で確認したので、他のバージョンでどうなるかは不明
  Dim myRow As ListRow
  Dim i As Long
  i = 0
  For Each myRow In table1.ListRows
    If i Mod 2 = 0 Then
      myRow.Range(10) = "=[@売上1]+[@売上2]"
    Else
      myRow.Range(10) = "=[@売上3]*3"
    End If
    i = i + 1
  Next myRow
  
  '数式に関数を使う場合　@と[]の使い方には注意で
  table1.ListRows(1).Range(10) = "=SUM([@[売上1]:[売上3]])"  'SUM関数の指定はこうなるらしい
  table1.ListRows(1).Range(10) = "=MAX([@[売上1]:[売上3]])"
  table1.ListRows(1).Range(10) = "=IF([@売上1]>5000,[@売上2]*10,""売上1が5000以下"")"
  'IF文はこんな感じか
  
End Sub



Sub GGG()  'テーブルの行挿入・行削除、列挿入・列削除

  Dim table1 As ListObject
  
  Worksheets("実験").Cells.Clear
  Call CopyData1
  
  Set table1 = ActiveSheet.ListObjects.Add(xlSrcRange, ActiveSheet.Cells(1, 2).CurrentRegion, , xlYes)
  
  table1.ListRows.Add Position:=5  '5行目に行を挿入。下の行はシフトされる
  
  table1.ListRows.Add  '最終行に行を追加
  
  table1.ListRows(5).Delete  '5行目を削除
  
  'table1.ListRows.Delete  'これで最終行を削除はできない
  
  
  table1.ListColumns.Add Position:=3  '3列目に列を挿入
  table1.HeaderRowRange(3) = "追加列" '見出しを設定
  
  table1.ListColumns(3).Delete   '3列目を削除

End Sub



Sub HHH()  'テーブルのフィルター

  Dim table1 As ListObject
  
  Worksheets("実験").Cells.Clear
  Call CopyData1
  
  Set table1 = ActiveSheet.ListObjects.Add(xlSrcRange, ActiveSheet.Cells(1, 2).CurrentRegion, , xlYes)
  table1.ShowTotals = True  '集計行を作成
  
  table1.DataBodyRange.AutoFilter Field:=4, Criteria1:="リンゴ"
  '4列目の値が「リンゴ」で絞込み　table1.DataBodyRange.AutoFilterでないと駄目らしい
  
  'table1.AutoFilter Field:=4, Criteria1:="リンゴ"   これはエラーになる
  
  table1.AutoFilter.ShowAllData   '絞り込み解除。これはDataBodyRangeではないという
  
  table1.DataBodyRange.AutoFilter 4, "桃"  'この省略形でもいい
  
  table1.AutoFilter.ShowAllData
  
  table1.DataBodyRange.AutoFilter 3, ">=5000", xlAnd, "<=15000"
  table1.DataBodyRange.AutoFilter 4, "桃"
  
  table1.AutoFilter.ShowAllData
  
  table1.DataBodyRange.AutoFilter 4, "???"   ' 任意の3文字
  
  '条件の指定はオートフィルタと同じみたい
End Sub


Sub III()  '列の末尾に列を追加し、見出しと数式を設定

  Dim table1 As ListObject
  
  Worksheets("実験").Cells.Clear
  Call CopyData1
  
  Set table1 = ActiveSheet.ListObjects.Add(xlSrcRange, ActiveSheet.Cells(1, 2).CurrentRegion, , xlYes)
  
  With table1.HeaderRowRange
    .Resize(1, 1).Offset(, .Count) = "集計列"
    '見出し行の末尾列の右のセルの値を"集計列"とする。自動的にこの列もテーブル範囲となる
    '結果として、末尾に列を追加し、見出しを"集計列"にすることになる

    .Resize(1, 1).Offset(1, .Count) = "=SUM([@[列1]:[列2]])"
    '追加した列のデータ部分の1行目に数式を設定。列全体に同じ数式が入る
  End With
  
End Sub



Sub JJJ()  'テーブルのデータ部分のデータのある最終行を取得する例

  Dim table1 As ListObject
  Dim i As Long
  Dim tempRow As Long
  Dim lastRow As Long
  
  Worksheets("実験").Cells.Clear
  Call CopyData1
  
  Set table1 = ActiveSheet.ListObjects.Add(xlSrcRange, ActiveSheet.Cells(1, 2).CurrentRegion, , xlYes)
  table1.ShowTotals = True  '集計行を作成
  
  table1.ListRows.Add  '最終行に行を追加
  table1.ListRows.Add
  table1.ListRows.Add
  
  table1.DataBodyRange.Cells(table1.DataBodyRange.Rows.Count - 1, 3) = 12563
  'データ部分の下から2行目に値を入れておく
  
  
  lastRow = -1
  For i = 1 To table1.DataBodyRange.Columns.Count
    tempRow = GetLastDataRow(table1, i)
    If lastRow < tempRow Then
      lastRow = tempRow
    End If
  Next i
  
  If lastRow > -1 Then
    Debug.Print "データのある最終行は: " & lastRow
  Else
    Debug.Print "テーブルには全くデータが無い"
  End If

End Sub

'*****  データのある最終行を取得  ************
Private Function GetLastDataRow(ByVal table As ListObject, ByVal columnIndex As Long) As Long
'テーブル型の変数は、値渡しで受け取ることが可能らしい

  Dim i As Long
  
  GetLastDataRow = -1 'データのある行が見つからない場合は、-1をリターン
  
  For i = table.DataBodyRange.Rows.Count To 1 Step -1
    If table.DataBodyRange.Cells(i, columnIndex) <> "" Then
      GetLastDataRow = i
      Exit Function
    End If
  Next i
End Function



Sub KKK()  'テーブルのセルにハイパーリンクを設定
  Dim table1 As ListObject
  
  Worksheets("実験").Cells.Clear
  Call CopyData1
  
  Set table1 = ActiveSheet.ListObjects.Add(xlSrcRange, ActiveSheet.Cells(1, 2).CurrentRegion, , xlYes)
  
  Worksheets("実験").Cells(100, 1) = "AAAAAAAAA"
  
  table1.DataBodyRange.Cells(1, 1) = "100行目へ"
  table1.DataBodyRange.Parent.Hyperlinks.Add Anchor:=table1.DataBodyRange.Cells(1, 1), _
    Address:="", SubAddress:="実験!R100C1"
  'テーブルのデータ部分の左上セルに、実験シートのA100セルへのハイパーリンクを設定
  'Address:="" は必要
End Sub



Sub LLL()  'テーブルのソート
  Dim table1 As ListObject
  
  Worksheets("実験").Cells.Clear
  Call CopyData4
  
  Set table1 = ActiveSheet.ListObjects.Add(xlSrcRange, ActiveSheet.Cells(1, 2).CurrentRegion, , xlYes)
  
  With table1.Sort
    .SortFields.Clear  'ソートを解除
    .SortFields.Add Key:=table1.HeaderRowRange(3), SortOn:=xlSortOnValues, Order:=xlAscending
    '3列目の値で、昇順にソート
    .Header = xlYes
    .Apply
  End With
  
  With table1.Sort
    .SortFields.Clear  'ソートを解除
    .SortFields.Add Key:=table1.HeaderRowRange(2), SortOn:=xlSortOnValues, Order:=xlDescending
    '2列目の値で、降順にソート
    .SortFields.Add Key:=table1.HeaderRowRange(3), SortOn:=xlSortOnValues, Order:=xlAscending
    '2番目のソート条件を追加。3列目の値で、昇順にソート
    .Header = xlYes
    .Apply
  End With

End Sub



Sub MMM()  'テーブルを条件で絞り込んだ状態で、データ部分を選択する
'テーブルは絞込みをした状態で範囲選択すると、変なクセがあるので注意

  Dim table1 As ListObject
  Dim var1 As Variant

  Worksheets("実験").Cells.Clear
  Call CopyData1
  
  Set table1 = ActiveSheet.ListObjects.Add(xlSrcRange, ActiveSheet.Cells(1, 2).CurrentRegion, , xlYes)
  
  table1.ShowTotals = True  '集計行を作成
  table1.DataBodyRange.AutoFilter 4, "桃"  '絞込み
  
  table1.DataBodyRange.Select   'テーブルのデータ部分を選択
  var1 = Selection.Value   'これはデータ部分全体が格納されてしまい、絞込みの意味が無い
  
  table1.DataBodyRange.SpecialCells(xlCellTypeVisible).Select
  var1 = Selection.Value
  'これは、データ部分の最初の行から、絞込みで非表示になっている行の直前までの範囲になる。理由は不明
  
  
  Worksheets("テーブル貼り付け").Cells.Clear  'テーブル範囲を貼り付けるシートをクリア
  
  table1.DataBodyRange.SpecialCells(xlCellTypeVisible).Select
  Selection.Copy
  Worksheets("テーブル貼り付け").Activate
  Worksheets("テーブル貼り付け").Cells(1, 1).Select
  Worksheets("テーブル貼り付け").Paste
  var1 = Selection.Value
  '絞り込んだテーブルをコピーして他のシートに貼り付け、それを範囲選択すれば、一応は絞り込んだ部分のみ取得できる
  
Stop

End Sub





**************  共有モジュールのコード   ************************************

Public Sub CopyData1()  'データ1のセル範囲をコピー・ペースト

  Worksheets("データ1").Activate
  Worksheets("データ1").Range(Cells(1, 2), Cells(26, 7)).Copy
  Worksheets("実験").Activate
  Worksheets("実験").Cells(1, 2).Select
  Worksheets("実験").Paste

End Sub


Public Sub CopyData2()  'データ1のセル範囲をコピー・ペースト

  Worksheets("データ1").Activate
  Worksheets("データ1").Range(Cells(1, 9), Cells(21, 12)).Copy
  Worksheets("実験").Activate
  Worksheets("実験").Cells(31, 2).Select
  Worksheets("実験").Paste

End Sub

Public Sub CopyData3()  'データ1のセル範囲をコピー・ペースト

  Worksheets("データ1").Activate
  Worksheets("データ1").Range(Cells(1, 14), Cells(31, 23)).Copy
  Worksheets("実験").Activate
  Worksheets("実験").Cells(1, 2).Select
  Worksheets("実験").Paste

End Sub


Public Sub CopyData4()  'データ1のセル範囲をコピー・ペースト

  Worksheets("データ1").Activate
  Worksheets("データ1").Range(Cells(1, 25), Cells(31, 31)).Copy
  Worksheets("実験").Activate
  Worksheets("実験").Cells(1, 2).Select
  Worksheets("実験").Paste

End Sub


'他のテーブルに重なっている部分が無いか、シートにオートフィルタが設定されていないかを確認
Public Function ReturnTable(ByVal range1 As Range) As ListObject

  Set ReturnTable = Nothing
  
  Dim ws As Worksheet
  Dim tbl As ListObject
  
  Set ws = range1.Worksheet
  
  For Each tbl In ws.ListObjects  '全てのテーブル
    If Not Intersect(range1, tbl.Range) Is Nothing Then
    ' Intersect:  複数セル範囲の、重なっている部分のセル範囲を取得
      Exit Function
    End If
  Next
  
  If ws.AutoFilterMode Then  'オートフィルタが設定されている場合
    If Not Intersect(range1, ws.AutoFilter.Range) Is Nothing Then
      Exit Function
    End If
  End If
  
  On Error Resume Next
  Set ReturnTable = ws.ListObjects.Add(xlSrcRange, range1, , xlYes)  'ここでテーブル追加
  If Err Then
    MsgBox Err.Description
  End If
End Function



'テーブルの全スタイル名をシートに出力
Public Sub OutputAllTableStyle()
  Dim tblStyle As TableStyle
  Dim arrTableStyle() As String
  Dim i As Long
  
  ReDim arrTableStyle(0)
  
  For Each tblStyle In ThisWorkbook.TableStyles

    arrTableStyle(UBound(arrTableStyle)) = tblStyle.Name
    ReDim Preserve arrTableStyle(UBound(arrTableStyle) + 1)
  Next
  
  Worksheets("テーブルの全スタイル").Activate
  For i = 0 To UBound(arrTableStyle)
    Cells(i + 16, 2).Value = arrTableStyle(i)
  Next i

End Sub
```