VBA クラスモジュールでExcelのテーブル(ListObject)を操作する

今回はVBAでちょっと扱いにくいExcelのテーブル(ListObject)をクラスモジュールで包んで簡単に操作できるようにするコードを紹介。

作り方

まずVBEで対象のブックを選択し、挿入メニューからクラスモジュールを挿入する。

挿入されたクラスモジュール(Class1)を選択し、プロパティウインドウ(表示されてなければF4キーで表示)から、モジュールのオブジェクト名を「TableOperator」に変更する。

クラスモジュールTableOperatorをダブルクリックで開き、コードウインドウに以下のコードを張り付ける。

Option Explicit
Public ListObject As ListObject
Public OverwriteExtraBlankRecord As Boolean
Public ReadExtraBlankRecord As Boolean
Private rowCursor As Long

Sub MoveFirst()
    rowCursor = 0
End Sub

Sub SetTable(start_cell As Range)
    Set Me.ListObject = start_cell.ListObject
    Me.MoveFirst
End Sub

Function GetNext() As Range
    rowCursor = rowCursor + 1
    Set GetNext = Me.ListObject.ListRows(rowCursor).Range
End Function

Function HasNext() As Boolean
    If ReadExtraBlankRecord Then
        HasNext = rowCursor < Me.ListObject.ListRows.Count
    Else
        HasNext = rowCursor < GetLastUsedRowIndex
    End If
End Function

Private Function IsBlank(target_range As Range) As Boolean
    Dim arr: arr = target_range.Value
    Dim r
    For Each r In arr
        'If r = Empty Then ←12/5 1:01修正。
        'TwitterでimihitoさんにEmptyとの比較だと0もTrueになる旨の指摘と改善コード教えてもらいました。
        If IsEmpty(r) Then
            IsBlank = True
            Exit For
        End If
    Next
End Function

Private Function GetLastUsedRowIndex() As Long
    Dim ret As Long
    ret = Me.ListObject.ListRows.Count
    Do While IsBlank(Me.ListObject.ListRows(ret).Range)
        ret = ret - 1
    Loop
    GetLastUsedRowIndex = ret
End Function

Sub AddItem(ParamArray data())
    If UBound(data) + 1 = Me.ListObject.ListColumns.Count Then
        Dim targetRange As Range
        If OverwriteExtraBlankRecord Then
            Dim cursor As Long
            cursor = GetLastUsedRowIndex + 1
            If cursor < Me.ListObject.ListRows.Count Then
                Set targetRange = Me.ListObject.ListRows(cursor).Range
            Else
                Set targetRange = Me.ListObject.ListRows.Add.Range
            End If
        Else
            Set targetRange = Me.ListObject.ListRows.Add.Range
        End If
        
        Dim i As Long
        For i = LBound(data) To UBound(data)
            targetRange.Item(i + 1).Value = data(i)
        Next
    End If
End Sub

使い方

今のところ機能はデータの追加と、全データの列挙だけ。
初心者用に説明を書こうと思ったけれど、本文での説明が面倒だったのでサンプルコードはいつもよりコメント多め。

データの追加

今回は以下の食材テーブルに新しく、魚を追加するサンプルを作った。

↓コピペ用の表はこちら

種目	品名	価格
果物	いちご	150
果物	ばなな	100
果物	りんご	200
野菜	キャベツ	150
野菜	なすび	100
野菜	レタス	120
肉	牛肉	300
肉	豚肉	200
肉	鶏肉	100

※Excelに貼り付けてテーブル化してください。

※標準モジュールに書くコードは以下を参照してください。

Sub データ追加()
    'まず任意の変数を、TableOperator型で宣言します。
    Dim foods As TableOperator
    
    '次にその変数に新しいTableOperatorを代入します。
    Set foods = New TableOperator
    
    'そして、SetTableメソッドにテーブルの開始セルを指定すると、準備完了です。
    foods.SetTable Range("A1")
    
    '↓これは記事中で解説します。
    foods.OverwriteExtraBlankRecord = True
    
    'あとは、データを指定して追加するだけ。
    foods.AddItem "魚", "いわし", 100
    foods.AddItem "魚", "あじ", 150
    foods.AddItem "魚", "さば", 200
End Sub

OverwriteExtraBlankRecordプロパティについて

※前置きが長くなるけれども、しばしお付き合いください。
Excelのテーブル機能はふつう、先に示したようにデータをぎりぎりまで入力する想定で作られている。
ただ悲しいかな一般的にテーブルの機能は正しく認知されておらず、ただのデザイン機能だと思って使ってる方も多い。

それで、以下のようにデータの追加に備えてテーブルに余裕を持たせておくなんてことが行われるのだが、、、

これがVBAでテーブルを扱う際の悲劇の始まり。

Excelはテーブル範囲=データ範囲だと認識するため、上の画像では2～18行目まで17個のデータが入っていると認識する。
そこにデータをAddすると、当然こうなる↓

本来は、「テーブル機能をきちんと理解する」という根本解決がベストだけれど、共有で使っているファイルなんかだとなかなか全員に周知徹底も難しい。

そこで！
長くなったけれど、OverwriteExtraBlankRecordの出番。
というかもう答え出たね。

そう、これは私が用意した、余分な空行を上書きするという意味のプロパティ。
デフォルトだとFalseだけれど、Trueにすることでこのとおり↓

ちゃんと狙った位置に入る。

全データ出力

全データを出力するサンプルはこちら。
※Debug.Printを使用しているので、イミディエイトウインドウが表示されていなければ「Ctrl+G」で表示させておいてください。

Sub 全データ出力()
    Dim foods As TableOperator
    Set foods = New TableOperator
    foods.SetTable Range("A1")
    'ここまでの準備は一緒
    
    '最初の行へ移動
    foods.MoveFirst
    
    'ReadExtraBlankRecordをTrueにすると余分な空行も含めて出力。デフォルトはFalse
    '↓サンプルを示す目的なので一旦コメントアウトしている。
    'foods.ReadExtraBlankRecord = True
    Debug.Print "---start---"
    
    'HasNextがTrueの間、GetNextを繰り返す。
    Do While foods.HasNext
    
        'GetNextは1レコード分のRangeを返し、内部で保持しているカーソルを次の行へ移す。
        Dim food As Range
        Set food = foods.GetNext
        
        '返ってきたRangeに引数をひとつ与えると、その列のデータが取れるので、
        'Tabでくっつけて表示
        Debug.Print food(1) & vbTab & food(2) & vbTab & food(3)
        
    Loop
    Debug.Print "---end---"
End Sub

初心者向け(?)の解説は以上。
ここから下は余談。

改善が望まれる個所

• HasNextが呼ばれるたびにGetLastUsedRowIndexが実行されるので効率が悪い。
• Whereなどのメソッドでデータの絞り込みがしたい。

これは条件が1つなら実現したのだけど、複数条件を付けたくなったところで面倒臭くなって詰んだ。

※私はこれ以上つくりません。一応、コードの残骸を掲載しておくので好きにしてください。
　あくまで残骸なので、このままではただのDebug.Printです。

クラスモジュールTableOperatorに追加するコード

Private Function compare(value As Variant, condition As String) As Boolean
    Dim ret As Boolean
    Dim op As String: op = Split(condition)(0)
    Dim cond As Variant: cond = Mid(condition, InStr(1, condition, " ") + 1)
    Select Case TypeName(value)
        Case "String": cond = CStr(cond)
        Case "Date": cond = CDate(cond)
        Case "Long": cond = CLng(cond)
        Case "Integer": cond = CInt(cond)
        Case "Double": cond = CDbl(cond)
        Case "Currency": cond = CCur(cond)
        Case "Single": cond = CSng(cond)
        Case "Boolean": cond = CBool(cond)
        Case "Byte": cond = CByte(cond)
    End Select
    
    Select Case op
        Case "=": ret = value = cond
        Case ">": ret = value > cond
        Case "<": ret = value < cond
        Case ">=": ret = value >= cond
        Case "<=": ret = value <= cond
        Case "<>": ret = value <> cond
        Case "Like": ret = value Like cond
        Case Else: ret = False
    End Select
    compare = ret
End Function
Function Whare(column_name As String, condition As String) As Range
    Dim columnindex, i, j
    columnindex = Me.ListObject.ListColumns(column_name).Index
    For i = 1 To Me.ListObject.ListRows.Count
        If compare(Me.ListObject.ListRows(i).Range(columnindex).value, condition) Then
            For j = 1 To Me.ListObject.ListColumns.Count
                Debug.Print Me.ListObject.ListRows(i).Range(j).value,
            Next
            Debug.Print
        End If
    Next
End Function

用意するテーブル

サンプルコード

Sub フィルターテスト()
    Dim foods As TableOperator
    Set foods = New TableOperator
    foods.SetTable Range("A1")
    Debug.Print "----"
    foods.Whare "価格", "<= 100"
    Debug.Print "----"
    foods.Whare "種目", "= 魚"
    Debug.Print "----"
    foods.Whare "種目", "= 果物"
    Debug.Print "----"
    foods.Whare "品名", "Like *ご"
End Sub

以上