ExcelワークシートをVBA上でデータベーステーブルのように扱うクラスモジュール database_on_worksheet

Excelの表をVBAで操作する際、基本的には列と行でセルを指定する形となりますが、Accessデータベースのように項目名で検索したり、１行１行進めて処理したりできたら便利だと思ったことはありませんか？

住所が入力されている場所が、業者によって３列目だったり５列目だったり…「住所」で検索できればいいのに…

そんな気持ちに応える、Excel VBAクラスモジュールを作成しました。実際に仕事で使っていますが、なかなか評判が良い物です。ワークシートやADODB.Recordsetをこのクラスに放り込むと、AccessライクなFunctionが使えるようになります。

Excel VBA : Make worksheet like a database recordset, Search from item name, Find values...
You do not have to be conscious of columns or lines.

クラスモジュール database_on_worksheet

Option Explicit

Private DBItems As Dictionary

Public sheet_db As Worksheet
Public current_row
Public RecordCount
Public FieldCount
Public EOF As Boolean

Private first_found_row, first_found_Item, first_found_What

'set exist Worksheet, rowOffset : row where item exists
Public Function SetSheet(sheet_set, Optional rowOffset = 0)
    Dim cnt_clm, max_clm
    
    Set DBItems = New Dictionary
    Set sheet_db = sheet_set
    With sheet_db
        max_clm = .Cells(1 + rowOffset, .Columns.Count).End(xlToLeft).Column
        For cnt_clm = 1 To max_clm
            If Not DBItems.Exists(.Cells(1 + rowOffset, cnt_clm).Value) Then DBItems.Add .Cells(1 + rowOffset, cnt_clm).Value, cnt_clm
        Next
        current_row = 2 + rowOffset
        RecordCount = .Cells(.Rows.Count, 1).End(xlUp).Row - 1
        FieldCount = .Cells(1, .Columns.Count).End(xlToLeft).Column
        EOF = RecordCount = 0
    End With
        
End Function

'Recordset -> Worksheet -> set to this class
Public Function CopyFromRecordset(DBR As ADODB.Recordset, sheet_set As Worksheet, Optional PutOption = "New")
    Dim cnt_row, cnt_clm
    Application.ScreenUpdating = False
    With sheet_set
        Select Case PutOption
            Case "New"
                .Cells.Clear
                For cnt_clm = 1 To DBR.Fields.Count
                    .Cells(1, cnt_clm) = DBR.Fields.Item(cnt_clm - 1).Name
                Next
                SetSheet sheet_set
                cnt_row = 2
            Case "Add"
                cnt_row = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        End Select
        
        .Range("A" & cnt_row).CopyFromRecordset DBR
        current_row = 2
        RecordCount = .Cells(.Rows.Count, 1).End(xlUp).Row - 1
        FieldCount = .Cells(1, .Columns.Count).End(xlToLeft).Column
        EOF = RecordCount = 0
    End With
    Application.ScreenUpdating = True
End Function

'get value by item name in current row
Public Function dget(ItemName)
    dget = sheet_db.Cells(current_row, DBItems(ItemName)).Value
End Function

'put value by item name in current row ( with cell inner color option )
Public Function dput(ItemName, putValue, Optional putColorRGB)
    sheet_db.Cells(current_row, DBItems(ItemName)).Value = putValue
    
    If Not IsMissing(putColorRGB) Then
        sheet_db.Cells(current_row, DBItems(ItemName)).Interior.Color = putColorRGB
    End If
End Function

Public Function MoveFirst()
    current_row = 2
    EOF = current_row > RecordCount + 1
End Function

Public Function MoveNext()
    current_row = current_row + 1
    EOF = current_row > RecordCount + 1
End Function

'add item right of last item column
Public Function AddItem(ItemName)
    Dim add_column
    With sheet_db
        If Not DBItems.Exists(ItemName) Then
            add_column = FieldCount + 1
            DBItems.Add ItemName, add_column
            .Cells(1, add_column) = ItemName
            FieldCount = FieldCount + 1
        Else
            
        End If
    End With
End Function

Public Function Find(ItemName, What) As Boolean
    Dim range_finder As Range
    With sheet_db
        If DBItems.Exists(ItemName) Then
            Set range_finder = .Columns(DBItems(ItemName)).Find(What:=What, LookAt:=xlWhole)
            If Not range_finder Is Nothing Then
                Find = True
                current_row = range_finder.Row
                first_found_row = current_row
                first_found_Item = ItemName
                first_found_What = What
            Else
                Find = False
            End If
        End If
    End With
End Function

'useful with Do-While
Public Function FindNext() As Boolean
    Dim range_finder As Range
    With sheet_db
        If DBItems.Exists(first_found_Item) Then
            Set range_finder = .Columns(DBItems(first_found_Item)).Find(What:=first_found_What, LookAt:=xlWhole, After:=.Cells(current_row, DBItems(first_found_Item)))
            If Not range_finder Is Nothing Then
                If first_found_row <> range_finder.Row Then
                    FindNext = True
                    current_row = range_finder.Row
                Else
                    FindNext = False
                    current_row = range_finder.Row
                End If
            Else
                FindNext = False
            End If
        End If
    End With
End Function

使用例

Dim my_dow As New database_on_worksheet

'既存ワークシートを指定する場合
my_dow.SetSheet ThisWorkbook.Worksheets("doburi")

'ADODB.Recordsetを指定する場合（新規・追加選択可）
my_dow.CopyFromRecordset my_rec, ThisWorkbook.Worksheets("kaina"), "New"

'上記どちらかを使用します。項目名と列番号が紐づいて登録され、最初のレコード（２行目）がポイントされます。

'項目を追加する
my_dow.AddItem "costomer_key"

'Do Whileで全レコードを回すことができます。
Do While Not my_dow.EOF
    Dim current_name, current_id
    current_name = my_dow.dget("customer_name")
    current_id = my_dow.dget("costomer_id")
    my_dow.dput "customer_key", current_name & "-" & current_id

    my_dow.MoveNext
Loop

'Findを使うと、見つけた行がポイントされ、値入力・取得ができます。
my_dow.AddItem "complainer"
If my_dow.Find("costomer_id", "Yasukuni_1889") Then
    my_dow.dput "complainer", "O", RGB(255,0,0)
End If

質問・改善要望はコメント欄にどうぞ！
WELCOME! Questions and improvement requests in the comments section.