Excelが大好きだ！

Excel大好き経理マンがExcelの事を書き綴っていきます。


スポンサードリンク

表データを操作する６つの方法(データフィルタ編)

SQL SQLite VBA

シリーズ前回ではシートのデータを各機能に取り込み、そのまま別シートに貼り付ける動作を体感してみた。

www.excellovers.com

今回は取り込んだデータに絞り込みをかけた上で、別シートに貼り付ける動作を体感してみた。

６つの方法

最初に紹介した5つの方法にSQLiteを追加した6つの方法で体感します。

前回と同じく10万行×6列のデータです。
データ内の性別列で『女』となっているデータを抽出して別シートに貼り付けます。

抽出の結果、データ数は50,161件になっています。

時間計測関数　改

モジュールレベル変数だった「CheckTime」をStatic変数に変更してプロシージャ内部に格納しました。

Function CheckTimePrintOut(Message As String, Optional StartTime As Double = 0) As String
     Static CheckTime As Double
     Debug.Print Message & Timer - IIf(StartTime = 0, CheckTime, StartTime)
     CheckTime = Timer
End Function

処理時間

機能 取込 選別 貼付 Total
配列 0.08 0.05 1.72 1.87
Collection 0.80 0.12 1.68 2.67
Dictionary 2.09 1.21 2.24 5.61
Recordset 2.40 0 0.51 2.93
ArrayList 2.41 1.14 2.00 5.56
SQLite 8.65 0 30.71 39.40

やはりSQLite(For Excel)がダントツで遅いですね。
しかしデータ量にかなり処理速度が影響を受けるのか、全データで処理した時の半分近くの時間になりました。

他の方法もRecordsetを除いて処理量が減った分若干短縮されています。
Recordsetのみほぼ変わりません。

選別に関しても全データの時とSQL文を替えただけで何も変わりませんし、配列経由ではなくCopyfromRecordsetを使用しているからか貼り付けの速度も変わりません。

試してみた感想

冒頭記載の通り、一度各機能に取り込んだデータに絞り込みをかけた上で、シートに転記しました。

配列

  • 速い
  • 慣れてるので書くときに悩まない
  • データ選別する機能はない
    • 一次元配列だとFilter関数が使用可能
  • 貼付け時にセル範囲を抽出後のデータ数に合わせれば配列をRedim Preserveでサイズ縮小しなくても良い
    • 元データのサイズの配列を用意しおけば良いので、Redim Preserveの最終次元しかサイズ変更できない点を気にしなく良い
    • この方法にデメリットはあるのだろうか？

Collection

  • データを選別する機能はない
  • 要素数を気にせずに使える
  • 一度Collectionに入れる意味がない
    • 最初にCollectionに入れるときに選別をする

Dictionary

  • データを選別する機能はない
  • Collectionと違ってKeyが必須
  • 一度Dictionaryに入れる意味がない
    • 最初にDictionaryに入れるときに選別をする
  • 遅い

空のRecordset

  • Filterメソッドで一瞬で選別
  • 高速
  • 列数が増えると列設定がめんどくさい

ArrayList

  • データを選別する機能はない
  • 一度ArrayListに入れる意味がない
    • 最初にArrayListに入れるときに選別をする
  • 遅い

SQLite

  • めちゃくちゃ遅い
  • テーブル設定がめんどくさい
  • SQLite For Excelの準備がめんどくさい
  • SQL文で自由自在に選別・加工が可能

まとめ

今回のルールではそれぞれの機能を利用してデータの選別が出来ればというものでした。
しかしRecordsetとSQLite以外はフィルタ機能に該当するものがなく、いずれの方法も一件ずつデータを抽出して判別するしか有りませんでした。
※フィルタ機能に該当するものがあれば是非教えて下さい。

しかもデータをセルに転記するということだけに限るなら、配列でも要素数を気にする必要がないという気付きが有りました。
今回のような用途であればCollection・Dictionaryを使用するメリットを感じられませんでした。

今回のテストでは

  • 高速かつ慣れている配列
  • それなりに速くフィルタ設定が柔軟かつ簡単なRecordset

の2点が良いなぁという結果になりました。

各機能コード

各機能のコード全文です。

配列

Sub データ選別_配列()
'時間計測開始-----------------------------------------
     Worksheets("Sheet2").Cells.Clear
     Dim StartTime As Double: StartTime = Timer
     CheckTimePrintOut "配列：データ取り込み開始：", Timer
'配列取込開始-----------------------------------------
     Dim myArray As Variant: myArray = Worksheets("Sheet1").Range("A1").CurrentRegion
     CheckTimePrintOut "データ取り込み終了："
'データ選別--------------------------------------------
     Dim mySelectedVar() As Variant: ReDim mySelectedVar(UBound(myArray) - 1, UBound(myArray, 2) - 1)
     Dim MaxRow As Long: MaxRow = UBound(mySelectedVar)
     Dim MaxColumn As Long: MaxColumn = UBound(mySelectedVar, 2)
     Dim n As Long
     Dim i As Long
     Dim SelectCount As Long
          
     For i = 0 To MaxColumn
          mySelectedVar(0, i) = myArray(1, i + 1)
     Next
     For i = 0 To MaxRow
          If myArray(i + 1, r.性別) = "女" Then
               SelectCount = SelectCount + 1
               For n = 0 To MaxColumn
                    mySelectedVar(SelectCount, n) = myArray(i + 1, n + 1)
               Next
          End If
     Next
     CheckTimePrintOut "データ選別終了："
'データ貼付け-----------------------------------------
     Worksheets("Sheet2").Range("A1").Resize(SelectCount+1, MaxColumn+1).Value = mySelectedVar
     CheckTimePrintOut "データ貼り付け終了："
     Debug.Print "全処理時間:" & Timer - StartTime
End Sub

Collection

Sub データ選別_Collection()
'時間計測開始-----------------------------------------
     Worksheets("Sheet2").Cells.Clear
     Dim StartTime As Double: StartTime = Timer
     CheckTimePrintOut "Collection：データ取り込み開始：", Timer
'Collection取込開始-----------------------------------------
     Dim myCol As Collection: Set myCol = New Collection
     Dim myRngs As Range: Set myRngs = Worksheets("Sheet1").Range("A1").CurrentRegion
     Dim myRng As Range
     For Each myRng In Intersect(myRngs, Worksheets("Sheet1").Range("A:A"))
          myCol.Add myRng.Resize(1, myRngs.Columns.Count).Value
     Next
     CheckTimePrintOut "データ取り込み終了："
'データ選別-------------------------------------------
     Dim mySelectCol As Collection: Set mySelectCol = New Collection
     Dim col As Variant
     Dim i As Long
     Dim n As Long
     
     mySelectCol.Add myCol(1)
     For Each col In myCol
          If col(1, r.性別) = "女" Then mySelectCol.Add col
     Next
     CheckTimePrintOut "データ選別終了："
'データ貼付け-----------------------------------------
     Dim myData As Variant: ReDim myData(mySelectCol.Count, 6)
     For Each col In mySelectCol
          For n = 1 To 6
               myData(i, n - 1) = col(1, n)
          Next
          i = i + 1
     Next
     Worksheets("Sheet2").Range("A1").Resize(UBound(myData), UBound(myData, 2)).Value = myData
     CheckTimePrintOut "データ貼り付け終了："
'クロージング-----------------------------------------
     Set myCol = Nothing
     CheckTimePrintOut "クロージング："
     Debug.Print "全処理時間:" & Timer - StartTime
End Sub

Dictionary

Sub データ選別_Dictionary()
'時間計測開始-----------------------------------------
     Worksheets("Sheet2").Cells.Clear
     Dim StartTime As Double: StartTime = Timer
     CheckTimePrintOut "Dictionary：データ取り込み開始：", Timer
'Dictionary取込開始-----------------------------------------
     Dim myDic As Dictionary: Set myDic = New Dictionary 'Microsoft Scripting Runtime参照設定が必要
     Dim myRngs As Range: Set myRngs = Worksheets("Sheet1").Range("A1").CurrentRegion
     Dim myRng As Range
     For Each myRng In Intersect(myRngs, Worksheets("Sheet1").Range("A:A"))
          myDic.Add Left(myRng.Value, 1) & Format(myRng.Row, "00000"), myRng.Resize(1, myRngs.Columns.Count).Value
     Next
     CheckTimePrintOut "データ取り込み終了："
'データ選別-------------------------------------------
     Dim mySelectDic As Dictionary: Set mySelectDic = New Dictionary
     Dim dic As Variant
     Dim i As Long
     Dim n As Long
     mySelectDic.Add Left(myRngs.Cells(1, 1).Value, 1) & Format(myRngs.Cells(1, 1).Row, "00000"), myDic(Left(myRngs.Cells(1, 1).Value, 1) & Format(myRngs.Cells(1, 1).Row, "00000"))
     For Each dic In myDic
          If myDic(dic)(1, r.性別) = "女" Then mySelectDic.Add dic, myDic(dic)
     Next
     CheckTimePrintOut "データ選別終了："
'データ貼付け-----------------------------------------
     Dim myData As Variant: ReDim myData(mySelectDic.Count, 6)
     For Each dic In mySelectDic
          For n = 1 To 6
               myData(i, n - 1) = mySelectDic(dic)(1, n)
          Next
          i = i + 1
     Next
     Worksheets("Sheet2").Range("A1").Resize(UBound(myData) + 1, UBound(myData, 2) + 1).Value = myData
     CheckTimePrintOut "データ貼り付け終了："
'クロージング-----------------------------------------
     Set myDic = Nothing
     CheckTimePrintOut "クロージング："
     Debug.Print "全処理時間:" & Timer - StartTime
End Sub

Recordset

Sub データ選別_空Recrodset()
'時間計測開始-----------------------------------------
     Worksheets("Sheet2").Cells.Clear
     Dim StartTime As Double: StartTime = Timer
     CheckTimePrintOut "Recordset：データ取り込み開始：", Timer
'空のRecordset作成-----------------------------------------
     Dim myRS As ADODB.Recordset
     Set myRS = New ADODB.Recordset
     With myRS.Fields
          .Append "名前", adVarWChar, -1
          .Append "ふりがな", adVarWChar, -1
          .Append "アドレス", adVarWChar, -1
          .Append "性別", adVarWChar, -1
          .Append "年齢", adInteger
          .Append "誕生日", adDate
     End With
     myRS.Open
'Recordsetデータ取り込み-----------------------------------------
     CheckTimePrintOut "データ取り込み開始："
     Dim myListObj As ListObject: Set myListObj = Worksheets("Sheet1").ListObjects("t_個人情報")
     Dim i As Long
     Dim n As Long
     Dim ColumnName As Variant
     
     Dim myRngs As Range: Set myRngs = Worksheets("Sheet1").Range("A1").CurrentRegion
     Dim myRng As Range
     Dim FieldList As Variant: FieldList = Array("名前", "ふりがな", "アドレス", "性別", "年齢", "誕生日")
     Dim ValueList As Variant
     For Each myRng In Intersect(myRngs, Worksheets("Sheet1").Range("A2:A" & Rows.Count))
          myRS.AddNew FieldList, DownDimension(myRng.Resize(1, myRngs.Columns.Count).Value)
     Next

     myRS.MoveFirst
     CheckTimePrintOut "データ取り込み終了："
'データ選別--------------------------------------------
     myRS.Filter = "性別 = '女'"
     CheckTimePrintOut "データ選別終了："
'データ貼り付け-----------------------------------------
     Dim myWS As Worksheet: Set myWS = Worksheets("Sheet2")
     For i = 1 To myRS.Fields.Count
          myWS.Cells(1, i).Value = myRS.Fields(i - 1).Name
     Next
     myWS.Range("A2").CopyFromRecordset myRS
     myRS.MoveFirst
     CheckTimePrintOut "データ貼り付け終了："
'クロージング-----------------------------------------
     myRS.Close
     Set myRS = Nothing
     
     CheckTimePrintOut "クロージング："
     Debug.Print "全処理時間:" & Timer - StartTime
End Sub
'-----------------------------------------------
Function DownDimension(二次元配列 As Variant) As Variant
     Dim myVar As Variant
     Dim i As Long
     ReDim myVar(0 To UBound(二次元配列, 2) - 1)
     For i = 0 To UBound(myVar)
          myVar(i) = 二次元配列(1, i + 1)
     Next
     DownDimension = myVar
End Function

ArrayList

Sub データ選別_ArrayList()
'時間計測開始-----------------------------------------
     Worksheets("Sheet2").Cells.Clear
     Dim StartTime As Double: StartTime = Timer
     CheckTimePrintOut "ArrayList：データ取り込み開始：", Timer
'ArrayListデータ取り込み-----------------------------------------
     Dim myList As Object: Set myList = CreateObject("System.Collections.ArrayList")
     Dim myRngs As Range: Set myRngs = Worksheets("Sheet1").Range("A1").CurrentRegion
     Dim myRng As Range
     For Each myRng In Intersect(myRngs, Worksheets("Sheet1").Range("A:A"))
          myList.Add myRng.Resize(1, myRngs.Columns.Count).Value
     Next
     CheckTimePrintOut "データ取り込み終了："
'データ選別--------------------------------------------
     Dim mySelectList As Object: Set mySelectList = CreateObject("System.Collections.ArrayList")
     Dim Var As Variant
     Dim i As Long
     Dim n As Long
     
     mySelectList.Add myList(0)
     For Each Var In myList
          If Var(1, r.性別) = "女" Then mySelectList.Add Var
     Next
     CheckTimePrintOut "データ選別終了："
'データ貼り付け-----------------------------------------
     Dim myData As Variant: ReDim myData(mySelectList.Count, 6)
     For Each Var In mySelectList
          For n = 1 To 6
               myData(i, n - 1) = Var(1, n)
          Next
          i = i + 1
     Next
     Worksheets("Sheet2").Range("A1").Resize(UBound(myData), UBound(myData, 2)).Value = myData
     CheckTimePrintOut "データ貼り付け終了："
'クロージング-----------------------------------------
     Set myList = Nothing
     CheckTimePrintOut "クロージング："
     Debug.Print "全処理時間:" & Timer - StartTime
End Sub

SQLite

Sub データ選別_SQLite()
     Dim myDbHandle As Long
     Dim myStmtHandle As Long
     
'時間計測開始-----------------------------------------
     Worksheets("Sheet2").Cells.Clear
     Dim StartTime As Double: StartTime = Timer
CheckTimePrintOut "SQLite：データ取り込み開始：", Timer
     
     SQLite3Initialize
     SQLite3OpenV2 "test.db3", _
          myDbHandle, SQLITE_OPEN_READWRITE + SQLITE_OPEN_MEMORY, ""
     SQLite3PrepareV2 myDbHandle, "create table test(名前 text,ふりがな text,アドレス text,性別 text,年齢 Integer,誕生日 text)", myStmtHandle
     SQLite3Step myStmtHandle
     SQLite3Finalize myStmtHandle
CheckTimePrintOut "SQLite：InMemoryDB作成：", Timer
'SQLiteデータ取り込み-----------------------------------------
     SQLiteBeginTransaction myDbHandle
     Dim myListObj As ListObject: Set myListObj = Worksheets("Sheet1").ListObjects("t_個人情報")
     Dim myRngs As Range: Set myRngs = Worksheets("Sheet1").Range("A1").CurrentRegion
     Dim myRng As Range
     Dim mySQL As String
     Dim i As Long
     For Each myRng In Intersect(myRngs, Worksheets("Sheet1").Range("A2:A" & Rows.Count))
          mySQL = "insert into test values("""
          mySQL = mySQL & myRng.offset(, 0).Value & ""","""
          mySQL = mySQL & myRng.offset(, 1).Value & ""","""
          mySQL = mySQL & myRng.offset(, 2).Value & ""","""
          mySQL = mySQL & myRng.offset(, 3).Value & ""","
          mySQL = mySQL & myRng.offset(, 4).Value & ","""
          mySQL = mySQL & myRng.offset(, 5).Value & """)"
          
          SQLite3PrepareV2 myDbHandle, mySQL, myStmtHandle
          SQLite3Step myStmtHandle
          SQLite3Finalize myStmtHandle
     Next
     SQLiteCommitTransaction myDbHandle
     CheckTimePrintOut "データ取り込み終了："
'データ貼り付け-----------------------------------------
     mySQL = "select * from test where 性別 = '女'"
     Dim myData() As Variant
     SQLiteSelect mySQL, myDbHandle, True, myData
     CheckTimePrintOut "配列転記終了："
     Worksheets("Sheet2").Range("A1").Resize(UBound(myData), UBound(myData, 2) + 1).Value = myData
     CheckTimePrintOut "データ貼り付け終了："
'クロージング-----------------------------------------
     
     CheckTimePrintOut "クロージング："
     Debug.Print "全処理時間:" & Timer - StartTime
End Sub
'####################################
'SQLiteSelect
'引数：SQL：データを抽出するためのSQL文を指定する
'         dbHandle：データベースのハンドルLong型の空変数を指定する
'         Header：データベースのタイトル行を返り値に含めるかどうか
'         ArrayDatas：要素数未設定の配列を設定する。ByRef設定なので配列を直接編集する
'機能：SQLで抽出されたレコードを２次元配列で返す
'####################################
Function SQLiteSelect(SQL As String, dbHandle As Long, Header As Boolean, ByRef ArrayDatas() As Variant) As Variant

     If Left(SQL, 6) <> "select" Then
        ArrayDatas = Array()
        SQLiteSelect = "NotSelectSQL"
        Exit Function
     End If
     
'レコード件数を取得する--------------------------------------------
     Dim myStmtHandle As Long
     Dim ReturnValue As Variant
     ReturnValue = SQLite3PrepareV2(dbHandle, "select count(*) from (" & SQL & ")", myStmtHandle)

'SQL文に不備がある場合
     If ReturnValue = SQLITE_ERROR Then
        ArrayDatas = Array()
        Exit Function
     End If
     
'レコード件数を変数へ
     ReturnValue = SQLite3Step(myStmtHandle)
     Dim MaxRecordCount As Long: MaxRecordCount = ColumnValue(myStmtHandle, 0, SQLite3ColumnType(myStmtHandle, 0))
     SQLite3Finalize myStmtHandle
     
     If MaxRecordCount = 0 Then
        ArrayDatas = Array()
        Exit Function
     End If

     ReturnValue = SQLite3PrepareV2(dbHandle, SQL, myStmtHandle)
     ReturnValue = SQLite3Step(myStmtHandle)
     
     Dim colCount As Long
     colCount = SQLite3ColumnCount(myStmtHandle)
     ReDim ArrayDatas(MaxRecordCount + Header * -1, colCount - 1)

'レコードデータを変数へ転記----------------------------------------
'列毎のデータタイプを配列へ(データ取得時のオブジェクトへのアクセス回数軽減？)
'引数HeaderがTrueなら抽出データのヘッダーを配列の１行目に追加
     Dim i As Long
     Dim n As Long
     Dim colType() As Long
     ReDim colType(colCount - 1)
          
     For n = 0 To colCount - 1
          colType(n) = SQLite3ColumnType(myStmtHandle, n)
          If Header Then ArrayDatas(i, n) = SQLite3ColumnName(myStmtHandle, n)
     Next
     i = i - Header
CheckTimePrintOut "ヘッダーを配列に転記："

'EOFか？？？(エラー？)になるまでレコード取得を繰り返す
'MaxRecordCountを取得してるからFor_Nextでもいいのでは？
     Do Until ReturnValue = SQLITE_DONE Or ReturnValue = SQLITE_MISUSE
          For n = 0 To colCount - 1
               ArrayDatas(i, n) = ColumnValue(myStmtHandle, n, colType(n))
          Next
          i = i + 1
          ReturnValue = SQLite3Step(myStmtHandle)
     Loop
CheckTimePrintOut "データを配列に転記："
End Function
#If Win64 Then
Function ColumnValue(ByVal stmtHandle As LongPtr, ByVal ZeroBasedColIndex As Long, ByVal SQLiteType As Long) As Variant
#Else
Function ColumnValue(ByVal stmtHandle As Long, ByVal ZeroBasedColIndex As Long, ByVal SQLiteType As Long) As Variant
#End If
    Select Case SQLiteType
        Case SQLITE_INTEGER:
            'SQLite3ColumnInt32→SQLite3ColumnDouble　Excel上Long型で処理されて桁あふれする為
            ColumnValue = SQLite3ColumnDouble(stmtHandle, ZeroBasedColIndex)
        Case SQLITE_FLOAT:
            ColumnValue = SQLite3ColumnDouble(stmtHandle, ZeroBasedColIndex)
        Case SQLITE_TEXT:
            ColumnValue = SQLite3ColumnText(stmtHandle, ZeroBasedColIndex)
        Case SQLITE_BLOB:
            ColumnValue = SQLite3ColumnText(stmtHandle, ZeroBasedColIndex)
        Case SQLITE_NULL:
            ColumnValue = Null
    End Select
End Function

Private Function ResultNumtoStr(ResultNumber As Long) As String
     Dim ReturnValue As String
     
     Select Case ResultNumber
          Case 1
               ReturnValue = "SQLITE_ERROR"
          Case 14
               ReturnValue = "SQLITE_CANTOPEN"
          Case 21
               ReturnValue = "SQLITE_MISUSE"
          Case Else
               ReturnValue = "StatusNumber:" & ResultNumber
     End Select
     ResultNumtoStr = ReturnValue
End Function
Function SQLiteBeginTransaction(dbHandle As Long) As Long
     Dim myStmtHandle As Long
     Dim ReturnValue As Long
     
     ReturnValue = SQLite3PrepareV2(dbHandle, "BEGIN TRANSACTION", myStmtHandle)
     SQLite3Step myStmtHandle
     SQLite3Finalize myStmtHandle
     
     SQLiteBeginTransaction = ReturnValue
End Function
Function SQLiteCommitTransaction(dbHandle As Long) As Long
     Dim myStmtHandle As Long
     Dim ReturnValue As Long
     
     ReturnValue = SQLite3PrepareV2(dbHandle, "COMMIT TRANSACTION", myStmtHandle)
     SQLite3Step myStmtHandle
     SQLite3Finalize myStmtHandle
     
     SQLiteCommitTransaction = ReturnValue
End Function