Recordsetに高速でデータを追加する方法

最近このような記事を公開した。

www.excellovers.com

その際にtwitterのフォロワーさんからアドバイスを頂いたので備忘録。

アドバイス
コード差異箇所
- 高速化前
- 高速化後
AddNew 配列で高速化
- Fieldsプロパティ
- AddNew 配列
処理速度
まとめ
全コード
- 高速化前
- 高速化後

アドバイス

最近Recordset推しですが、中々厳しい結果ですね
Recordsetへの要素の追加は、AddNew 配列, 配列の方が、Fields().Value=や、Update 配列, 配列より早かった印象ですが、そのあたり考慮してもこの差は覆らないでしょうし… https://t.co/putWp1BVm6
— いみひと (@nukie_53) 2021年2月27日

Recordsetの処理が遅いことについて、高速な処理方法をアドバイス頂きました。

コード差異箇所

コードの全体像は記事の最後に記載しました。ここでは全体の中で異なる箇所、『Recordsetデータ取り込み』部分を抽出しました。

高速化前

     Dim myListObj As ListObject: Set myListObj = Worksheets("Sheet1").ListObjects("t_個人情報")
     Dim i As Long
     Dim n As Long
     Dim ColumnName As Variant

     With myListObj
          For i = 1 To .ListRows.Count
               myRS.AddNew
               ColumnName = Array("名前", "ふりがな", "アドレス", "性別", "年齢", "誕生日")
               For n = 0 To UBound(ColumnName)
                    myRS.Fields(ColumnName(n)) = .ListColumns(ColumnName(n)).DataBodyRange(i)
               Next
               myRS.Update
          Next
     End With
     myRS.MoveFirst

高速化後

     Dim myListObj As ListObject: Set myListObj = Worksheets("Sheet1").ListObjects("t_個人情報")
     Dim i 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("名前", "ふりがな", "アドレス", "性別", "年齢", "誕生日")

     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

AddNew 配列で高速化

Recordsetにデータを追加するにはAddNewメソッドを使用します。
AddNewメソッドには２つの追加方法があります。

Fields(列名).value = 値
AddNew 列名配列,値配列

Fieldsプロパティ

Fieldsプロパティを使用する方法では以下の手順を踏みます。

AddNewで列の追加
Fields(列名).value = 値を列の数だけ実行
Updateでデータの追加確定

AddNew 配列

AddNew配列の方法ではFieldsプロパティでは3段階の処理を行っていたものを1度の処理で実行できます。

AddNew 列名配列,値配列

列名配列・値配列共に全列を指定してもいいですし、必要な箇所のみ指定することも可能です。

AddNewの配列には1次元配列しか指定できません。
セル範囲を直接配列に代入した場合は2次元配列になります。

そのため今回の例では別関数で2次元配列を1次元配列に変換しています。

処理速度

差異のある『Recordsetデータ取り込み』だけで計測しました。
処理内容は100,000件×6列のデータをRecordsetに取り込んで、そのまま別シートにCopyfromRecordsetしました。

Fieldsプロパティ：8.63秒
AddNewメソッド：2.50秒

高速化前の約29％まで処理速度が高速化されました。

まとめ

凄いですね。
構文を工夫して高速化するって言うわけじゃなくて、基本的な使い方でこれだけ差が出てくるっていうのが。

最初に覚えたものを雛鳥のごとく盲信して使ってしまっています。
使い慣れたものでも一度振り返って見るだけでも高速化のタネに出会えそうです。

全コード

高速化前と高速化後の全コード記載します。

高速化前

Sub Recrodset_FieldValue()
'時間計測開始-----------------------------------------
     Worksheets("Sheet2").Cells.Clear
     Dim StartTime As Double: StartTime = Timer
     CheckTimePrintOut "FieldValue：処理開始：", 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

     With myListObj
          For i = 1 To .ListRows.Count
               myRS.AddNew
               ColumnName = Array("名前", "ふりがな", "アドレス", "性別", "年齢", "誕生日")
               For n = 0 To UBound(ColumnName)
                    myRS.Fields(ColumnName(n)) = .ListColumns(ColumnName(n)).DataBodyRange(i)
               Next
               myRS.Update
          Next
     End With
     myRS.MoveFirst
     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

高速化後

Sub Recrodset_配列AddNew()
'時間計測開始-----------------------------------------
     Worksheets("Sheet2").Cells.Clear
     Dim StartTime As Double: StartTime = Timer
     CheckTimePrintOut "AddNew：処理開始：", 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 ColumnName As Variant
     
     Dim myRngs As Range: Set myRngs = Worksheets("Sheet1").Range("A1").CurrentRegion
     Dim myRng As Range
     Dim FieldList As Variant: FieldList = Array("名前", "ふりがな", "アドレス", "性別", "年齢", "誕生日")

     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 "データ取り込み終了："
'データ貼り付け-----------------------------------------
     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```