自分用のメモなので、形は整ってないです。
テーブルの操作全般。大体のことはここに詰め込んだ
************** 標準モジュールのコード ************************************
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