VBAからGDI+を使う資料集
inet上の達人の方々から御教示いただいたコードを少しアレンジさせてもらっています（切り貼りとも言います）。
  1. ホーム
  2. Other
  3. adocodes


ExcelADO関係コードあれこれ

ExcelやAccessでADOを利用したコードで、QAサイトで回答したものが主です。
あまり受けは良くなかったかもしれませんが、振り返ってみるとADOでのExcel Book接続は結構使えそうな気がするのですが...

  1. 二つのCSVから選択クエリ
  2. CSVから所定の列（離散）だけを取込
  3. (Excel) ワークシートに置いたListBoxの2段階絞り込みをADOでやってみた
  4. (Excel) Sheet1の3条件に合致する値をSheet2から取得する
  5. (Access) GetStringを用いてCSVをエクスポートする際フィールド名をつける
  6. (Excel) UserForm上のTextBoxで、ComboBox様に1文字入力で候補表示を実現
  7. (Excel) ADOでワークブックに追記
  8. (Excel) 複数シートから、複数条件で検索して、集計用シートに出力
  9. (Excel) 複数条件を満足する値を、各行の特定（一つ）のセルに文字列でまとめて表示
  10. (Excel) 文字列のピボットテーブル的集計
  11. (VBScript) 二つのCSVファイルから不一致クエリで抽出
  12. (Access) SQL文でCSVの接続先を指定し、必要な列だけを既存テーブルにインポート
  13. (Access) SQL文でCSVの接続先を指定し、必要な列だけを既存テーブルにインポート2
  14. (Excel) accdb生成→xlBookとCSVへのリンクテーブル設定→結合クエリ
  15. (Excel) CursorLocationとかCursorTypeによる速度差
コンテンツリストに戻る 

'同一フォルダーにある二つのCSVファイルから、選択クエリでデータを取り出します
Sub test()
 Dim cn As Object
 Dim rs As Object
 Dim connectionString As String
 Dim csvFilePath As String
 Dim mySQL As String

 Set cn = CreateObject("ADODB.Connection")
 csvFilePath = ThisWorkbook.Path
 'CSVファイルにラベル（フィールド名）があるとする
connectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" _
 & "Data Source=" & csvFilePath & ";" _
 & "Extended Properties=""Text;HDR=YES;FMT=Delimited"""
 cn.Open connectionString
 mySQL = "SELECT 商品マスタ.商品コード, 受注データ一覧.商品番号, 受注データ一覧.カラー, 受注データ一覧.色 FROM 受注データ一覧.csv AS 受注データ一覧 LEFT JOIN 商品マスタ.csv AS 商品マスタ ON (受注データ一覧.商品番号 = 商品マスタ.商品番号) AND (受注データ一覧.色 = 商品マスタ.色) AND (受注データ一覧.カラー = 商品マスタ.カラー);"
Set rs = cn.Execute(mySQL)
 ThisWorkbook.Worksheets(1).Range("A1").CopyFromRecordset rs
 rs.Close
 cn.Close
 Set rs = Nothing
 Set cn = Nothing
 End Sub
コンテンツリストに戻る 


'CSVから所定の列（離散）だけを取込
'ADOを使わないとうまくいかない理由があった覚えあるのですが、経緯を忘れてしまいました。
'Schemeファイルの自動作成まで盛り込んであります

Sub test02()
 Dim cn As Object
 Dim rs As Object
 Dim mySQL As String
 Dim inportColumnArray As Variant
 Dim strFields As String
 Dim csvfilepath As String, csvfilename As String

 csvfilepath = GetDesktopPath
 csvfilename = "testdata20130804.csv"
 '抽出する列番号を指定
inportColumnArray = Array(1, 2, 3, 4, 5, 7)
 strFields = "F" & Join(inportColumnArray, ",F")

 Set cn = CreateObject("ADODB.Connection")
 With cn
 'Office2007以降
.Provider = "Microsoft.ace.OLEDB.12.0"
 'Office2003以前 2007以降でも動きますが
' .Provider = "Microsoft.Jet.OLEDB.4.0"

 '敢えてHdr=Noにして先頭行も読込み、後ほど捨てる。
'型の自動判別のMaxScanRows無効のバグはace.OLEDB.12.0でも直っていない様です
'仕方が無いのでSchema.iniにも手を出してみました

.ConnectionString = "Data Source=" & csvfilepath & ";" & _
 "Extended Properties='Text; HDR=NO; FMT=Delimited'"
 .Open
 End With
 Set rs = CreateObject("ADODB.Recordset")
 mySQL = "SELECT " & strFields & " FROM " & csvfilename & ";"
 '型変換エラーで悩まされる時は生かして下さい。すべて文字列で取り込みます。
'Extended Properties=""Excel x.0;IMEX=1""" で良いと後で思い当たりましたが､他の型を指定して、
'使う事もあるかも知れないので、残しておきます。
'makeSchema csvfilepath, csvfilename, strFields

 rs.Open mySQL, cn, adOpenFowardOnly
 'とりあえずテンポラリシートに貼り付けて、ファイル名を付与する
'一行目以外を目的のシートの末尾に貼り付ける等して使用する
With Sheets("Sheet2")
 .Cells.Clear
 .Range("B1").CopyFromRecordset rs
 .Range("B1").CurrentRegion.Offset(0, -1).Resize(, 1).Value = csvfilename
 End With

 Set rs = Nothing
 cn.Close: Set cn = Nothing
 End Sub

 '取込型指定のSchama.iniを作る
Private Sub makeSchema(csvfilepath As String, csvfilename As String, strFields As String)
 Dim FSO As Object
 Dim i As Long
 Dim buf As Variant

 buf = Split(strFields, ",")
 Set FSO = CreateObject("Scripting.FileSystemObject")
 'OverWrite=true:default
 With FSO.CreateTextFile(csvfilepath & "\" & "Schema.ini")
 .writeline "[" & csvfilename & "]"
 .writeline "ColNameHeader = False"
 .writeline "Format = CSVDelimited"
 For i = 0 To UBound(buf)
 .writeline "Col" & CStr(i + 1) & "=" & buf(i) & " Char"
 Next i
 .Close
 End With
 Set FSO = Nothing
 End Sub

 'デスクトップのパス取得
Private Function GetDesktopPath() As String
 Dim wScriptHost As Object, strInitDir As String
 Set wScriptHost = CreateObject("Wscript.Shell")
 GetDesktopPath = wScriptHost.SpecialFolders("Desktop")
 Set wScriptHost = Nothing
 End Function
コンテンツリストに戻る 

'ワークシートに置いたListBoxの2段階絞り込みをADOでやってみた
'Microsoft ActiveX Data Objects Libraryに参照設定が必要です
'Tips:2003以前のProviderは、自ブックにADO接続するとメモリリークを起こすバグがあり、
'作業用ブックに書き出してから取り扱う様な配慮が必要。2007以降は大丈夫。

 '☆ Sheet1のシートモジュールに記載
Dim cn As ADODB.Connection

 Private Sub Worksheet_Activate()
 Dim rs As ADODB.Recordset
 Dim SQL As String
 Dim i As Long, j As Long

 Set cn = New ADODB.Connection
 Set rs = New ADODB.Recordset
 With cn
 .Provider = "Microsoft.ACE.OLEDB.12.0"
 .Properties("Extended Properties").Value = "Excel 12.0 Macro;HDR=YES"
 .Open ThisWorkbook.FullName
 End With

 SQL = "SELECT [取引番号],[取引社名] FROM [取引名簿$]"
rs.Open SQL, cn, adOpenStatic, adLockReadOnly
 If rs.BOF Then
 MsgBox "該当するデータは存在しません", vbCritical
 rs.Close
 Set rs = Nothing
 Exit Sub
 End If
 Me.ListBox1.Clear
 Me.ListBox2.Clear
 With Me.ListBox1
 .ColumnCount = rs.Fields.Count
 .ColumnWidths = "50;50"
 i = 0
 Do Until rs.EOF
 .AddItem rs.Fields(0).Value
 For j = 1 To rs.Fields.Count - 1
 .List(i, j) = rs.Fields(j).Value
 Next j
 rs.MoveNext
 i = i + 1
 Loop
 End With
 If rs.State = 1 Then rs.Close
 Set rs = Nothing
 End Sub

 Private Sub Worksheet_Deactivate()
 On Error Resume Next

 cn.Close
 Set cn = Nothing
 End Sub

 Private Sub ListBox1_Click()
 Dim rs As ADODB.Recordset
 Dim SQL As String
 Dim i As Long, j As Long

 Set rs = New ADODB.Recordset

 SQL = "SELECT [顧客名] FROM [顧客名簿$] WHERE [取引社名]='myCriteria';"
 SQL = Replace(SQL, "myCriteria", Me.ListBox1.List(Me.ListBox1.ListIndex, 1))
 rs.Open SQL, cn, adOpenStatic, adLockReadOnly
 If rs.BOF Then
 MsgBox "該当するデータは存在しません", vbCritical
 rs.Close
 Set rs = Nothing
 Exit Sub
 End If
 With Me.ListBox2
 .Clear
 Do Until rs.EOF
 .AddItem rs.Fields(0).Value
 rs.MoveNext
 Loop
 End With
 If rs.State = 1 Then rs.Close
 Set rs = Nothing
 End Sub

 Private Sub ListBox2_Click()
 MsgBox Me.ListBox2.List(Me.ListBox2.ListIndex)
 End Sub

’おまけ
'ワークシートの参照先の指定方法
'[Sheet1$] ワークシート全体　データはA1から始まっている必要は無いが、タイトル等余分なものが入っていると誤動作する
'[Sheet1$A1:B10] 名前無し範囲
'MyName 名前付き範囲
'https://support.microsoft.com/ja-jp/kb/257819
コンテンツリストに戻る 

'Sheet1の3条件に合致する値をSheet2から取得する
'Microsoft ActiveX Data Objects Libraryに参照設定が必要

 Sub test()
 Dim cn As ADODB.Connection
 Dim rs As ADODB.Recordset
 Dim SQL As String
 Dim i As Long
 Dim targetRange As Range, targetRow As Range
 Const srcSQL As String = "SELECT [箱] FROM [Sheet2$] WHERE [品目]='criteria1' AND [入荷日]=#criteria2# AND [出荷日]=#criteria3#;"

 Set cn = New ADODB.Connection
 Set rs = New ADODB.Recordset
 With cn
 .Provider = "Microsoft.ACE.OLEDB.12.0"
 .Properties("Extended Properties").Value = "Excel 12.0 Macro;HDR=YES"
 .Open ThisWorkbook.FullName
 End With
 With Sheets("Sheet1")
 Set targetRange = .Range("A1").CurrentRegion
 Set targetRange = Intersect(targetRange, targetRange.Offset(1, 0))
 End With
 For Each targetRow In targetRange.Rows
 SQL = srcSQL
 For i = 1 To 3
 SQL = Replace(SQL, "criteria" & CStr(i), targetRow.Cells(i).Value)
 Next i
 rs.Open SQL, cn, adOpenStatic, adLockReadOnly
 If Not rs.BOF Then
 targetRow.Cells(3).Offset(0, 1).Value = rs.Fields(0).Value
 End If
 rs.Close
 Next targetRow
 Set rs = Nothing
 cn.Close
 Set cn = Nothing
 End Sub
コンテンツリストに戻る 


'AccessからADOのGetStringを用いてCSVをエクスポートする際にフィールド名をつけたい

'Tips
'Accessお仕着せのオートナンバーフィールドのあるデータで試験したところ、
'エクセルに読み込む時にエラーになって悩みました。
'結局CSVファイルの頭にID...という文字があると、エクセルはSYLKファイルと判断して
'エラーを出すという事が分かりました。強行すればCSVとして開く事は可能です。

Sub test()
 Dim cnn As ADODB.Connection
 Dim rst As ADODB.Recordset
 Dim stSQL As String
 Dim stTBL As String
 Dim stPath As String 'フルパス
Dim objFSO As Object 'FileSystemObject
 Dim fsoTS As Object 'TextStream
 Dim tmp As Variant 'データ
Dim re As Variant 'データ件数
Dim stDocName As String
 Dim buf As String
 Dim i As Long

 Const ForAppending = 8

 stTBL = "Table1" 'テーブル名
'開始メッセージ
stDocName = "「" & stTBL & ".CSV」 ファイルをデスクトップに作成します"
If MsgBox(stDocName, vbYesNo) = vbNo Then Exit Sub
 'フルパス
stPath = myDesktopPath & "\" & stTBL & ".CSV"
 '読み取り専用でセット
Set cnn = CurrentProject.Connection
 Set rst = New ADODB.Recordset
 rst.CursorLocation = adUseClient
 stSQL = "SELECT * FROM " & stTBL
 rst.Open stSQL, cnn, adOpenForwardOnly, adLockReadOnly
 If rst.EOF Then
 stDocName = "出力するデータがありませんでした"
Else
 re = rst.RecordCount
 For i = 0 To rst.Fields.Count - 1
 If buf = "" Then
 buf = rst.Fields(i).Name
 Else
 buf = buf & "," & rst.Fields(i).Name
 End If
 Next i
 '文字列データ格納 (全データ出力、カンマ区切り)
tmp = rst.GetString(adClipString, , ",", vbNewLine)
 tmp = buf & vbCrLf & tmp
 '出力
Set objFSO = CreateObject("Scripting.FileSystemObject")
 With objFSO
 If .FileExists(stPath) Then
 '既存ファイル削除
Call .DeleteFile(stPath)
 End If
 Set fsoTS = .OpenTextFile(stPath, ForAppending, True)
 '文字列一括書き出し
fsoTS.WriteLine tmp
 End With
 Set fsoTS = Nothing: Set objFSO = Nothing
 stDocName = re & " 件の CSVデータを出力しました。"
End If
 MsgBox stDocName, vbOKOnly
 End Sub

 Function myDesktopPath() As String
 Dim myWSH As Object 'WScript

 'デスクトップパス取得
Set myWSH = CreateObject("WScript.Shell")
 myDesktopPath = myWSH.SpecialFolders("Desktop")
 Set myWSH = Nothing
 End Function
コンテンツリストに戻る 


'UserForm上のTextBoxで、ComboBox様に1文字入力で候補表示を実現してみた
'ADOなので%でワイルドカードも使えたりする(^^;)
Dim listSetFlag As Boolean
 Dim lineCount As Long
 Const initialHeight As Single = 18
 Const lineWidth As Single = 9

 Private Sub TextBox1_Change()
 Dim myText As String

 If Not listSetFlag Then
 myText = getUniqueList(Me.TextBox1.Value)
 If myText = "" Then
 Me.TextBox1.Value = ""
 Else
 listSetFlag = True
 With Me.TextBox1
 .Value = myText
 .Height = initialHeight + lineWidth * (lineCount - 1)
 .SelStart = 1
 End With
 End If
 End If
 End Sub

 Private Sub TextBox1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
 Dim buf1 As String, buf2 As String
 Dim myList As Variant
 Dim selectedline As Long

 If Me.TextBox1.Value = "" Then Exit Sub
 buf1 = Replace(Me.TextBox1.Text, vbCrLf, vbCr) '-A
 buf2 = Left(buf1, TextBox1.SelStart)
 selectedline = UBound(Split(buf2, vbCr))
 myList = Split(buf1, vbCr)
 MsgBox "選択されたのは " & myList(selectedline) & "です。"
 'initialize
 Me.TextBox1.Value = ""
 Me.TextBox1.Height = initialHeight
 lineCount = 0
 listSetFlag = False
 End Sub

 Private Sub UserForm_Initialize()
 With Me.TextBox1
 .MultiLine = True
 .WordWrap = False
 .ZOrder fmZOrderFront
 .IMEMode = fmIMEModeOn
 .Height = initialHeight
 End With
 listSetFlag = False
 lineCount = 0
 End Sub

 Function getUniqueList(key As String) As String
 Dim cn As ADODB.Connection
 Dim rs As ADODB.Recordset
 Dim mySQL As String

 If key = "" Then
 getUniqueList = ""
 Exit Function
 End If
 Set cn = New ADODB.Connection
 'xl2007以降対応です。2003以前は、自ワークブックへの接続に関してメモリリークの問題が
'改善されていないので、別の方法をとるべきでしょう。
With cn
 .Provider = "Microsoft.ace.OLEDB.12.0"
 .ConnectionString = "Data Source=" & ThisWorkbook.FullName & ";" & _
 "Extended Properties='Excel 12.0; HDR=Yes'" '見出し無しの時はここをNoに
.Open
 End With
 Set rs = New ADODB.Recordset
 rs.CursorLocation = adUseClient
 '見出し無しの時はここの氏名に代えてF1を入れる
mySQL = Replace("select distinct 氏名 from [Sheet1$] where 氏名 like 'key%';", "key", key)
 rs.Open mySQL, cn, adOpenDynamic
 lineCount = rs.RecordCount
 If lineCount > 0 Then
 '改行をvbCrやvbLfで行っても動く（Aの文字数調整不要となる）が、変にちらつく
getUniqueList = rs.GetString(adClipString, , , vbCrLf)
 Else
 MsgBox "みつかりません"
getUniqueList = ""
 End If
 rs.Close: Set rs = Nothing
 cn.Close: Set cn = Nothing
 End Function
コンテンツリストに戻る 


'ADOでワークブックに追記
inputForm.xlsmのSheet1が入力フォームとします。同ブックのSheet2の3行目に数式を入れて、転記したいデータが一行に並ぶようにします。その範囲（ここではA3:E3)にtenkiという名前をつけます。Sheet2のA1にはデータ転記先のブックのパスを入れておきます。ここではdatabase.xlsxとします。
database.xlsxのSheet1の一行目に列見出しを入れておきます。（F1～F5が見出しのつもりです）今回はあまり関係無いですが、今後のために。
データ入力後、testを実行すると、database.xlsxにデータが転記されます。database.xlsxは開いておく必要はありません。（開いていても転記される様です）
Sub test()
 Dim blResult As Boolean
 With ThisWorkbook.Sheets("Sheet2")
 blResult = addRecord(.Cells(1).Value, "Sheet1", .Range("tenki"))
 End With
 End Sub

 Function addRecord(wbkpath As String, destSheetName As String, newDataRange As Range) As Boolean
 Dim cn As Object, rs As Object
 Dim mySQL As String
 Dim i As Long, j As Long

 Const adOpenStatic = 3
 Const adLockOptimistic = 3

 On Error GoTo errHandle
 Set cn = CreateObject("ADODB.Connection")
 Set rs = CreateObject("ADODB.Recordset")
 With cn
 .Provider = "Microsoft.ace.OLEDB.12.0"
 .ConnectionString = "Data Source=" & wbkpath & ";" & _
 "Extended Properties='Excel 12.0; HDR=Yes'"
 .Open
 End With
 mySQL = "select * from [" & destSheetName & "$]"
 rs.Open mySQL, cn, adOpenStatic, adLockOptimistic
 With rs
 For i = 1 To newDataRange.Rows.Count
 .addnew
 For j = 1 To newDataRange.Columns.Count
 .Fields(j - 1).Value = newDataRange.Cells(i, j).Value
 Next j
 .Update
 Next i
 End With
 errHandle:
 If Err.Number = 0 Then
 addRecord = True
 Else
 Debug.Print Err.Number & Err.Description
 End If
 If Not rs Is Nothing Then
 If rs.State = 1 Then rs.Close
 Set rs = Nothing
 End If
 If Not cn Is Nothing Then
 If rs.State = 1 Then rs.Close
 Set cn = Nothing
 End If
 End Function
コンテンツリストに戻る 

'複数シートから、複数条件で検索して、集計用シートに出力
Sub test()
 Dim cn As Object, rs As Object
 Dim mySQL As String, tableAddress As String
 Dim i As Long
 Dim srcSheet As Worksheet, destSheet As Worksheet
 Dim nextOutputCell As Range

 Const adUseclient As Long = 3

 On Error GoTo errHandle
 Set cn = CreateObject("ADODB.Connection")
 Set rs = CreateObject("ADODB.Recordset")
 rs.CursorLocation = adUseclient
 With cn
 .Provider = "Microsoft.ace.OLEDB.12.0"
 .ConnectionString = "Data Source=" & ThisWorkbook.FullName & ";" & _
 "Extended Properties='Excel 12.0; HDR=Yes'"
 .Open
 End With
 Set destSheet = ThisWorkbook.Sheets("Sheet1")
 '検索範囲を空白行も含めて大きめに設定、実際に合わせてアレンジが必要
tableAddress = "A2:C1000"

 '最初のシート以外を全て検索対象とする。
'対象シートには少なくともA2:C2に見出しが設定されていないとエラー-21472179041になる
For i = 2 To ThisWorkbook.Worksheets.Count
 Set srcSheet = ThisWorkbook.Sheets(i)
 mySQL = "select 現場名,本支店名,距離 from [" & srcSheet.Name & "$" & tableAddress & "] where 現場名='fieldName' AND 本支店名='branchName';"
 mySQL = Replace(mySQL, "fieldName", destSheet.Range("A1"))
 mySQL = Replace(mySQL, "branchName", destSheet.Range("B1"))
 rs.Open mySQL, cn
 If rs.RecordCount > 0 Then
 With destSheet
 Set nextOutputCell = .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0)
 End With
 nextOutputCell.CopyFromRecordset rs
 End If
 rs.Close
 Next i
 errHandle:
 If Err.Number <> 0 Then
 Debug.Print Err.Number & Err.Description
 End If
 If Not rs Is Nothing Then
 If rs.State = 1 Then rs.Close
 Set rs = Nothing
 End If
 If Not cn Is Nothing Then
 If cn.State = 1 Then cn.Close
 Set cn = Nothing
 End If
 End Sub
コンテンツリストに戻る 

'複数条件を満足する値を、各行の特定（一つ）のセルに文字列でまとめて表示
'条件2,値2,条件3,値3...といった感じで単独セルにまとめる
Sub test()
 Dim cn As Object, rs As Object, rs2 As Object
 Dim mySQL As String, buf As String
 Dim srcSheet As Worksheet, destSheet As Worksheet
 Dim mycell As Range

 Const adClipString As Long = 2

 Set cn = CreateObject("ADODB.Connection")
 Set rs = CreateObject("ADODB.Recordset")
 Set rs2 = CreateObject("ADODB.Recordset")
 With cn
 .Provider = "Microsoft.ace.OLEDB.12.0"
 .ConnectionString = "Data Source=" & ThisWorkbook.FullName & ";" & _
 "Extended Properties='Excel 12.0; HDR=Yes'"
 .Open
 End With
 Set srcSheet = ThisWorkbook.Sheets("Sheet1")
 Set destSheet = ThisWorkbook.Sheets("Sheet2")
 destSheet.Range("A1:B1").Value = Array("名前", "内容")
Set mycell = destSheet.Range("A2")
 mySQL = "select distinct 名前 from [" & srcSheet.Name & "$];"
 rs.Open mySQL, cn
 Do Until rs.EOF
 mySQL = "select 内容,日時 from [" & srcSheet.Name & "$] where 名前='" & rs.Fields(0).Value & "';"
 rs2.Open mySQL, cn
 buf = rs2.GetString(adClipString, 5, ":", ",")
 buf = Left(buf, Len(buf) - 1)
 mycell.Value = rs.Fields(0).Value
 mycell.Offset(0, 1).Value = buf
 Set mycell = mycell.Offset(1, 0)
 rs2.Close
 rs.movenext
 Loop
 Set rs2 = Nothing
 rs.Close
 Set rs = Nothing
 cn.Close
 Set cn = Nothing
 End Sub
コンテンツリストに戻る 


'文字列のピボットテーブル的集計をADOでやってみる
Const adOpenFowardOnly As Long = 0

 Sub test()
 Dim cn As Object
 Dim rs0 As Object, rs As Object, rs2 As Object
 Dim mySQL As String, mySQL2 As String
 Dim destRange As Range
 Dim i As Long, j As Long

 Set cn = CreateObject("ADODB.Connection")
 With cn
 .Provider = "Microsoft.ace.OLEDB.12.0"
 .connectionstring = "Data Source=" & ThisWorkbook.FullName & ";" & _
 "Extended Properties='Excel 12.0; HDR=YES'"
 .Open
 End With
 'rs0 フィールド名取得用
’フィールド名固定で良ければもっと簡単になる
Set rs0 = CreateObject("ADODB.Recordset")
 rs0.Open "SELECT * FROM [Sheet1$];", cn, adOpenFowardOnly
 'rs グループ化したRecordset
 Set rs = CreateObject("ADODB.Recordset")
 mySQL = "SELECT F1,F2,F3 FROM [Sheet1$] GROUP BY F1,F2,F3;"
 For i = 1 To 3
 mySQL = Replace(mySQL, "F" & CStr(i), rs0.Fields(i - 1).Name)
 Next i
 rs.Open mySQL, cn, adOpenFowardOnly

 Sheets("Sheet2").Cells.Clear
 Set destRange = Sheets("Sheet2").Range("A2")
 For i = 1 To 3
 destRange.Offset(, i - 1).Item(0) = rs0.Fields(i - 1).Name
 Next i
 For i = 1 To 100
 destRange.Offset(, 2 + i).Item(0) = rs0.Fields(3).Name & CStr(i)
 Next i
 Do Until rs.EOF
 For i = 0 To 2
 destRange.Offset(, i).Value = rs.Fields(i).Value
 Next i
 mySQL2 = "SELECT F4 FROM [Sheet1$] WHERE F1='F1Value' AND F2 = 'F2Value' AND F3 = 'F3Value';"
 For i = 1 To 4
 If i < 4 Then mySQL2 = Replace(mySQL2, "F" & CStr(i) & "Value", rs.Fields(i - 1).Value)
 mySQL2 = Replace(mySQL2, "F" & CStr(i), rs0.Fields(i - 1).Name)
 Next i
 'rs2 グループ化した組み合わせ毎に該当するリストを取得
Set rs2 = CreateObject("ADODB.Recordset")
 rs2.Open mySQL2, cn, adOpenFowardOnly
 j = 3
 Do Until rs2.EOF
 destRange.Offset(, j).Value = rs2.Fields(0).Value
 rs2.MoveNext
 j = j + 1
 Loop
 Set rs2 = Nothing
 rs.MoveNext
 Set destRange = destRange.Offset(1, 0)
 Loop
 Set rs0 = Nothing
 Set rs = Nothing
 cn.Close: Set cn = Nothing
 End Sub
コンテンツリストに戻る 


'VBScript 二つのCSVファイルから不一致クエリで抽出
Dim cn
 Dim rs
 Dim connectionString
 Dim csvFilePath
 Dim item
 Dim mySQL
 Dim fso, dstFile
 Dim buf

 Set cn = CreateObject("ADODB.Connection")
 Set fso = CreateObject("Scripting.FileSystemObject")
 Set dstFile = fso.CreateTextFile("c:\testfile.txt", True)
 csvFilePath = "C:\"
 'CSVファイルにラベル（フィールド名）が無いとする
connectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" _
 & "Data Source=" & csvFilePath & ";" _
 & "Extended Properties=""Text;HDR=NO;FMT=Delimited"""
 cn.Open connectionString
 mySQL = "SELECT tableA.F1, tableA.F2, tableA.F3" _
 & " FROM A.csv AS tableA LEFT JOIN B.csv AS tableB ON (tableA.F3=tableB.F3) AND (tableA.F2=tableB.F2) AND (tableA.F1=tableB.F1)" _
 & " WHERE (((tableB.F3) Is Null));"
 Set rs = cn.Execute(mySQL)
 Do While rs.EOF = False
 buf= chr(34) & rs.fields(0) & """,""" & rs.fields(1) & """,""" & rs.fields(2) & chr(34)
 dstFile.WriteLine buf
 rs.MoveNext
 Loop

 dstFile.Close
 rs.Close
 cn.Close
 Set rs = Nothing
 Set cn = Nothing
 Set fso = Nothing
コンテンツリストに戻る 


'Microsoft ActiveX Data Objects 6.1 Library 等に参照設定(Access2010)
'SQL文でCSVの接続先を指定して、必要な列だけを既存テーブルにインポート
'CSV用に別のConnectionを生成しないで良い
'本例ではフィールド名F1, F2, F4というテーブルをあらかじめ作成しておく
'また、ファイルが読込済みか確認するためのテーブルも設けて、読み込んだファイル名を記録しておく
'ファイル先頭に0のデータが続くと整数と見なされてしまう（AccessDBのフィールド型に関係無く）
'このため、Schema.iniの生成も盛り込んでいる。

'ADOに参照設定要
Private Declare Function GetTickCount Lib "kernel32" () As Long

Sub extractCSV()
  Dim cn As ADODB.Connection
  Dim rs As ADODB.Recordset
  Dim csvFolderName As String
  Dim srcTable As String
  Dim tableName As String
  Dim mySQL As String, mySQL2 As String
  Dim filename As String
  Dim fileList As Collection
  Dim i As Long
  Dim startTime As Long
  
  Set cn = CurrentProject.Connection
  Set rs = New ADODB.Recordset
  rs.CursorLocation = adUseClient
  tableName = "T_importedData"
  
  startTime = GetTickCount
  csvFolderName = GetDesktopPath & "\testCSVs\"
  Set fileList = getFileList(csvFolderName, "*.csv")
  For i = 1 To fileList.Count
    'check if already imported
    rs.Open "SELECT * FROM T_importedFileList WHERE filename ='" & fileList.Item(i) & "';", cn
    If rs.RecordCount = 0 Then
      'import CSV
      filename = fileList.Item(i)
      filename = Replace(filename, ".", "#")
      'サブクエリの様な書き方ですね
      mySQL = "INSERT INTO MyTableName ( F1, F2, F4 ) " & _
        "SELECT [csvfilename].F1, [csvfilename].F2, [csvfilename].F4 " & _
        "FROM csvfilename IN ""csvFolderName"" ""Text;HDR=NO;"";"
      mySQL = Replace(mySQL, "MyTableName", tableName)
      mySQL = Replace(mySQL, "csvFolderName", csvFolderName)
      mySQL = Replace(mySQL, "csvfilename", filename)
      'Schema.iniを生成
      makeSchema csvFolderName,filename
      cn.Execute mySQL
      'resist imported file
      mySQL2 = "INSERT INTO T_importedFileList ( fileName) VALUES ('" & fileList.Item(i) & "');"
      cn.Execute mySQL2
      DoEvents: DoEvents: DoEvents
    End If
    If rs.State = 1 Then rs.Close
  Next i
  cn.Close
  Set cn = Nothing
  Debug.Print GetTickCount - startTime
  MsgBox "処理終了"
End Sub

'Schema.iniを生成する（既存上書き） 
Sub makeSchema(csvFilePath As String, csvFileName As String)
  Dim strSchema() As String
  Dim buf As String
  Dim FSO As Object
  
  ReDim strSchema(1 To 11)
  'ファイル名を指定しないと無効。またワイルドカードの様な事はできない。従ってコードで都度変更の必要あり。
  strSchema(1) = "[csvFileName]"
  strSchema(1) = Replace(strSchema(1), "csvFileName", csvFileName)
  strSchema(2) = "ColNameHeader = False"
  strSchema(3) = "CharacterSet = OEM"
  strSchema(4) = "Format = CSVDelimited"
  '型変換が思うようにいかない事があり、試行錯誤を余儀なくされた。AccessDBでは日付時刻型のところを文字列に指定したり...
  '下記F1～Fnのところは、Accessのフィールド名と異なっていても問題なし。
  strSchema(5) = "Col1=F1 Char"
  strSchema(6) = "Col2=F2 Char"
  strSchema(7) = "Col3=F3 Float"
  strSchema(8) = "Col4=F4 Char"
  strSchema(9) = "Col5=F5 Char"
  strSchema(10) = "Col6=F6 Float"
  strSchema(11) = "Col7=f7 Char"
  buf = Join(strSchema, vbCrLf)
  
  Set FSO = CreateObject("Scripting.FileSystemObject")
  With FSO.createtextfile(csvFilePath & "\" & "Schema.ini", True)
   .Write buf
   .Close
  End With
  Set FSO = Nothing
End Sub 

Private Function getFileList(folderName As String, wildCardFileName As String) As Object
  Dim fileList As New Collection, filename As Variant

  If Right(folderName, 1) <> "\" Then folderName = folderName & "\"
  filename = Dir(folderName & wildCardFileName, vbNormal)
  Do While filename <> ""
    fileList.Add Item:=filename
    filename = Dir()
  Loop
  Set getFileList = fileList
  Dir ""
End Function

Private Function GetDesktopPath() As String
  Dim wScriptHost As Object, strInitDir As String
  Set wScriptHost = CreateObject("Wscript.Shell")
  GetDesktopPath = wScriptHost.SpecialFolders("Desktop")
  Set wScriptHost = Nothing
End Function
コンテンツリストに戻る 

'12ではサブクエリ的にCSVからの選択を記述してレコードセット一個で済ませているが、
’CSVからのデータ取得部もRecordsetでやってみた。
'取り込んだファイル名を記録するテーブルの既読判断に最初三個目の
'Recordsetを開いていたが鬱陶しいのでDCountに変更した
'でもその後でExcelに載せ替えるときに、元に戻す羽目になった(^^;)

Sub extractCSV2()
  Dim cn As ADODB.Connection  'ACCDB
  Dim cn2 As ADODB.Connection 'csv
  Dim rs As ADODB.Recordset  'csv records
  Dim rs_dest As ADODB.Recordset  'ACCDB table
  Dim csvFolderName As String
  Dim tableName As String
  Dim mySQL As String, mySQL2 As String
  Dim filename As String
  Dim fileList As Collection
  Dim i As Long
  Dim startTime As Long
  
  startTime = GetTickCount
  
  Set cn = CurrentProject.Connection  'ACCDB
  Set cn2 = New ADODB.Connection      'csv
  
  Set rs_dest = New ADODB.Recordset
  Set rs = New ADODB.Recordset
  rs.CursorLocation = adUseClient
  tableName = "T_importedData"
  
  csvFolderName = GetDesktopPath & "\testCSVs\"
  With cn2
    .Provider = "Microsoft.ACE.OLEDB.12.0;Data Source=" & csvFolderName & ";"
    .Properties("Extended Properties").Value = "text;HDR=No;FMT=Delimited"
    .Open
  End With
  
  Set fileList = getFileList(csvFolderName, "*.csv")
  rs_dest.Open "T_importedData", cn, adOpenKeyset, adLockOptimistic

  For i = 1 To fileList.Count
    'check if already imported
    If DCount("*", "T_importedFileList", "filename='" & fileList.Item(i) & "'") = 0 Then
      'import CSV
      filename = fileList.Item(i)
      filename = Replace(filename, ".", "#")
      mySQL = "SELECT [csvfilename].F1, [csvfilename].F2, [csvfilename].F4 FROM csvfilename;"
      mySQL = Replace(mySQL, "csvfilename", filename)
      rs.Open mySQL, cn2
      'write csv data to table
      With rs_dest
          Do Until rs.EOF
          .AddNew
            rs_dest!F1 = rs!F1
            rs_dest!F2 = rs!F2
            rs_dest!F4 = rs!F4
          .Update
          rs.MoveNext
        Loop
      End With
      'resist imported file
      mySQL2 = "INSERT INTO T_importedFileList ( fileName) VALUES ('" & fileList.Item(i) & "');"
      cn.Execute mySQL2
      If rs.State = 1 Then rs.Close
      DoEvents: DoEvents: DoEvents
    End If
  Next i
  Set rs = Nothing
  Set rs_dest = Nothing
  If cn.State = 1 Then cn.Close
  If cn2.State = 1 Then cn2.Close
  Set cn = Nothing
  Set cn2 = Nothing
  Debug.Print GetTickCount - startTime
  MsgBox "処理終了"
End Sub
コンテンツリストに戻る 


'*******************************************************************************
' ExcelVBAからaccdbを生成し、Excel Workbook（この例では自ブック）のSheetへのリンクテーブル
' およびCSVファイルへのリンクテーブルを生成し、両リンクテーブル間の結合クエリを実行する
'　関数化した処理群で発生したエラーの処理に趣向を凝らしてみた
'
' 参照設定:Microsoft ADO Ext x.x for DDL and Security
' 　　　　 Microsoft Active Data Objects x.x Library

Sub createLinkedXLws()
  Dim accdbPath As String
  Dim xlwsPath As String, mySheetName As String
  Dim csvPath As String, csvFileName As String
  Dim destRange As Range
  Dim objCn As ADODB.Connection
  Dim objRS As ADODB.Recordset
  Dim strSQL As String
  
  On Error GoTo errHandle
  accdbPath = GetDesktopPath & "\test.accdb"
  xlwsPath = ThisWorkbook.FullName
  csvPath = GetDesktopPath
  csvFileName = "社員情報.csv"
  mySheetName = "社員マスタ"
  If makeAccDB(accdbPath) <> 0 Then
    Err.Raise 1001, , "create accdb error"
  End If
  If Not checkFile(xlwsPath) Then Exit Sub
 '自ブックへのリンク
  If CreateLinkedExternalTable( _
     accdbPath, _
     "Excel 12.0 Xml;DATABASE=" & xlwsPath & ";HDR=YES", mySheetName & "$", mySheetName) <> 0 Then
        Err.Raise 1002, , "worksheet link error"
  End If
'  CSVへのリンク
  If CreateLinkedExternalTable( _
     accdbPath, _
     "text;DATABASE=" & csvPath & ";HDR=YES; FMT=Delimited;", csvFileName, getBaseName(csvFileName)) Then
        Err.Range 1003, , "csv link error"
  End If
  'リンクテーブル間のクエリを実行し、結果をワークシートに貼り付ける
  Set destRange = ThisWorkbook.Sheets("Sheet1").Range("A1")
  Set objCn = New ADODB.Connection
  With objCn
    .Provider = "Microsoft.ace.OLEDB.12.0"
    .ConnectionString = "Data Source=" & accdbPath
    .Open
  End With
  strSQL = "SELECT A.社員コード, A.氏名, B.キャラクタ FROM 社員マスタ AS A INNER JOIN 社員情報 AS B ON A.社員コード = B.社員コード;"

  Set objRS = New ADODB.Recordset
  Set objRS = objCn.Execute(strSQL)
  pasteFieldNames objRS, destRange
  destRange.Offset(1, 0).CopyFromRecordset objRS
errHandle:
  If Err.Number <> 0 Then MsgBox Err.Number & " : " & Err.Description
  On Error GoTo 0
  On Error Resume Next
  If Not objRS Is Nothing Then objRS.Close
  Set objRS = Nothing
  If Not objCn Is Nothing Then objCn.Close
  Set objCn = Nothing
End Sub

'フィールド名を出力先ワークシートに出力
Sub pasteFieldNames(rs As ADODB.Recordset, destCell As Range)
  Dim i As Long
  
  For i = 0 To rs.Fields.Count - 1
    destCell.Offset(, i).Value = rs.Fields(i).Name
  Next i
End Sub

'新規テーブルを生成し、目的ファイル・ワークシートにリンク
'https://msdn.microsoft.com/ja-jp/library/cc376276.aspxから借用・改造
Function CreateLinkedExternalTable(strTargetDB As String, _
         strProviderString As String, _
         strSourceTbl As String, _
         strLinkTblName As String) As Boolean

   Dim catDB As ADOX.Catalog
   Dim tblLink As ADOX.Table
   
   On Error GoTo errHandle

   Set catDB = New ADOX.Catalog
   ' リンクを作成するデータベース内の Catalog を開きます。
   catDB.ActiveConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
         "Data Source=" & strTargetDB

   Set tblLink = New ADOX.Table
   With tblLink
      ' 新規 Table に名前を付け、その ParentCatalog プロパティを開いている
      ' Catalog に設定し、Properties コレクションへのアクセスを可能にします。
      .Name = strLinkTblName
      Set .ParentCatalog = catDB

      ' プロパティを設定してリンクを作成します。
      .Properties("Jet OLEDB:Create Link") = True
      .Properties("Jet OLEDB:Link Provider String") = strProviderString
      .Properties("Jet OLEDB:Remote Table Name") = strSourceTbl
   End With

   ' テーブルを Tables コレクションに関連付けます。
   catDB.Tables.Append tblLink

   Set catDB = Nothing
errHandle:
   CreateLinkedExternalTable = Err.Number
End Function

'データベース作成に成功したら0を戻す。失敗ならエラーコード
Function makeAccDB(accdbFullPath As String) As Long
    Dim cat As ADOX.Catalog
    Dim ConnectionString As String
    
    On Error GoTo errHandle
    Set cat = New ADOX.Catalog
    ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source="
    cat.Create ConnectionString & accdbFullPath & ";"
    Set cat = Nothing
    
errHandle:
    makeAccDB = Err.Number
End Function

'ファイル名のBaseを取得
Function getBaseName(fileFullPath As String) As String
  Dim FSO As Object
  Set FSO = CreateObject("Scripting.FileSystemObject")
  getBaseName = FSO.getBaseName(fileFullPath)
  Set FSO = Nothing
End Function

'デスクトップのパス取得
Private Function GetDesktopPath() As String
  Dim wScriptHost As Object, strInitDir As String
  Set wScriptHost = CreateObject("Wscript.Shell")
  GetDesktopPath = wScriptHost.SpecialFolders("Desktop")
  Set wScriptHost = Nothing
End Function
コンテンツリストに戻る 


'*******************************************************************************
' バッチ更新というのがあるのをみつけて試してみた。その過程で、CursorLocationとか、CursorTypeの
’　違いにより、実行スピードがどう違うのか計測した結果を示す。
' 既存mdbのテーブルの中身を全削除後、エクセルワークシートの12万行のデータを書き込む事例です。
'　参照設定:Microsoft Active Data Objects x.x Library

'結果概略
'　バッチ更新を複数行に対して行うには、CursorLocationをadUseClientにする必要があるが、
'　今回の事例では、それによって実行速度が10数倍遅くなるため、バッチ更新する意味が無い。
'　接続を切ったレコードセット処理を行うためのものらしい。いずれにしてもadUseClientは用途により非常に遅くなる。
'　用途により使えるカーソルタイプ、ロックタイプは異なると考えられるが、今回の事例では
'　adOpenDynamic≒adOpenForwardOnly > adOpenStatic≒adOpenKeysetで、左辺の方が2倍強速かった。
' 但し、Jet4.0プロバイダではadOpenDynamicは無効という記事もみつけた。
'　更に、Transactionを使うと、気持ち速くなる様だった。
'　RS.Addnewに配列を渡す方が、RS.Fields(n).Value = hoge で個々に渡すより、少し速かった。
’　速い方法を取れば、12万件書込が3秒強で、それほど苦になる時間では無い。

'トランザクションの使用
'3291～3307msec、僅かに速い？
Sub addData04()
    Dim cn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim srcTable As Range, fieldNameRange As Range
    Dim srcArray As Variant
    Dim refArray As Variant
    Dim fieldNameArray As Variant, fieldNameArray0() As Variant
    Dim i As Long, j As Long
    Dim starttime As Long
    
    Dim buf As Variant
    
    Set srcTable = Sheets("Sheet1").Range("A1").CurrentRegion
    srcArray = srcTable.Value
    Set fieldNameRange = srcTable.Rows(1)
    
    'フィールド名の範囲を0基底の配列に変換
    fieldNameArray = Application.Transpose(Application.Transpose(fieldNameRange))
    ReDim fieldNameArray0(0 To UBound(fieldNameArray) - 1)
    ReDim buf(0 To UBound(fieldNameArray) - 1)
    For i = 0 To UBound(fieldNameArray0)
      fieldNameArray0(i) = fieldNameArray(i + 1)
    Next i
       
    makeTable GetDesktopPath & "\SampleDataBase.mdb", "refList", Array("郵便番号")
    '接続オープン
    Set cn = New ADODB.Connection
    cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & GetDesktopPath & "\SampleDataBase.mdb;"
    cn.Execute "delete * from zipCodeTable;"
    starttime = GetTickCount
    
    Set rs = New ADODB.Recordset

    On Error GoTo 0
    On Error GoTo catch
    cn.BeginTrans

    '郵便番号辞書をテーブルに書き出し
    rs.Open "zipCodeTable", cn, adOpenDynamic, adLockPessimistic '3479
    For i = 2 To UBound(srcArray, 1)
      For j = 1 To fieldNameRange.Columns.Count
            buf(j - 1) = srcArray(i, j)
      Next j
      rs.AddNew fieldNameArray0, buf
    Next i
    rs.UpdateBatch
    rs.Close
    cn.CommitTrans

terminate:
    On Error Resume Next
    If rs.State = 1 Then rs.Close: Set rs = Nothing
    If cn.State = 1 Then cn.Close: Set cn = Nothing
    Debug.Print CStr(GetTickCount - starttime)
    Exit Sub
catch:
  cn.RollbackTrans
  GoTo terminate
End Sub


'複数行のバッチモード46317～47752msec劇遅
Sub addData03()
    Dim cn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim srcTable As Range, fieldNameRange As Range
    Dim srcArray As Variant
    Dim refArray As Variant
    Dim fieldNameArray As Variant, fieldNameArray0() As Variant
    Dim i As Long, j As Long
    Dim starttime As Long
    
    Dim buf As Variant
    Dim counter As Long
    
    starttime = GetTickCount
    
    Set srcTable = Sheets("Sheet1").Range("A1").CurrentRegion
    srcArray = srcTable.Value
    Set fieldNameRange = srcTable.Rows(1)
    
    'フィールド名の範囲を0基底の配列に変換
    fieldNameArray = Application.Transpose(Application.Transpose(fieldNameRange))
    ReDim fieldNameArray0(0 To UBound(fieldNameArray) - 1)
    ReDim buf(0 To UBound(fieldNameArray) - 1)
    For i = 0 To UBound(fieldNameArray0)
      fieldNameArray0(i) = fieldNameArray(i + 1)
    Next i
       
    '接続オープン
    Set cn = New ADODB.Connection
    cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & GetDesktopPath & "\SampleDataBase.mdb;"
    
    cn.Execute "Delete * from zipCodeTable;"
    Set rs = New ADODB.Recordset
'    実行時エラー '-2147217836 (80040e54)':変更を保留している行の数が､設定された上限を超えました｡
    'adUseServerだと一行しか保持しないらしく、adUseClientにすると劇遅になる。
    'adUseServerのまま一行ずつ書き込むと、普通の一行モードより遅いので価値無し。
    '接続を切ってからRecordsetを操作するとき専用という事か。
    rs.CursorLocation = adUseClient

    starttime = GetTickCount
    
    '郵便番号辞書をテーブルに書き出し
    rs.Open "zipCodeTable", cn, adOpenDynamic, adLockBatchOptimistic, adCmdTableDirect
    For i = 2 To UBound(srcArray, 1)
      For j = 1 To fieldNameRange.Columns.Count
            buf(j - 1) = srcArray(i, j)
      Next j
      rs.AddNew fieldNameArray0, buf
    Next i
    rs.UpdateBatch
    rs.Close

terminate:
    On Error Resume Next
    rs.Close: Set rs = Nothing
    cn.Close: Set cn = Nothing
  Debug.Print CStr(GetTickCount - starttime)
End Sub

'Addnewに配列を一括で渡す、10数%速くなる
'カーソルタイプは adOpenDynamicが速そうだが、検索していると、
'adOpenDynamicはJet4.0プロバイダには無効という記事があった...
Sub addData02()
    Dim cn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim srcTable As Range, fieldNameRange As Range
    Dim srcArray As Variant
    Dim refArray As Variant
    Dim fieldNameArray As Variant, fieldNameArray0() As Variant
    Dim i As Long, j As Long
    Dim starttime As Long
    
    Dim buf As Variant
    
    Set srcTable = Sheets("Sheet1").Range("A1").CurrentRegion
    srcArray = srcTable.Value
    Set fieldNameRange = srcTable.Rows(1)
    
    'フィールド名の範囲を0基底の配列に変換
    fieldNameArray = Application.Transpose(Application.Transpose(fieldNameRange))
    ReDim fieldNameArray0(0 To UBound(fieldNameArray) - 1)
    ReDim buf(0 To UBound(fieldNameArray) - 1)
    For i = 0 To UBound(fieldNameArray0)
      fieldNameArray0(i) = fieldNameArray(i + 1)
    Next i
       
    makeTable GetDesktopPath & "\SampleDataBase.mdb", "refList", Array("郵便番号")
    '接続オープン
    Set cn = New ADODB.Connection
    cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & GetDesktopPath & "\SampleDataBase.mdb;"
    cn.Execute "delete * from zipCodeTable;"
    starttime = GetTickCount
    
    Set rs = New ADODB.Recordset
    '59982～61621と10数倍遅くなる
'    rs.CursorLocation = adUseClient

    '郵便番号辞書をテーブルに書き出し
    rs.Open "zipCodeTable", cn, adOpenDynamic, adLockPessimistic '3291～3323
'    rs.Open "zipCodeTable", cn, adOpenDynamic, adLockOptimistic '3292～3323
'    rs.Open "zipCodeTable", cn, adOpenKeyset, adLockOptimistic '8237～8253
'    rs.Open "zipCodeTable", cn, adOpenForwardOnly, adLockOptimistic '3291～3682
'    rs.Open "zipCodeTable", cn, adOpenStatic, adLockOptimistic '8221～8268
    For i = 2 To UBound(srcArray, 1)
      For j = 1 To fieldNameRange.Columns.Count
            buf(j - 1) = srcArray(i, j)
      Next j
      rs.AddNew fieldNameArray0, buf
      'ここは入れないでも勝手にUpdateするそうである
'      rs.UpdateBatch
'      rs.Update
    Next i
    rs.Close

terminate:
    On Error Resume Next
    rs.Close: Set rs = Nothing
    cn.Close: Set cn = Nothing
  Debug.Print CStr(GetTickCount - starttime)
End Sub


'addNewしてフィールド毎代入、都度Update
'3728～3760msec
Sub addData01()
    Dim cn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim srcTable As Range, fieldNameRange As Range
    Dim srcArray As Variant
    Dim refArray As Variant
    Dim fieldNameArray As Variant, fieldNameArray0() As Variant
    Dim i As Long, j As Long
    Dim starttime As Long
    
    Set srcTable = Sheets("Sheet1").Range("A1").CurrentRegion
    srcArray = srcTable.Value
    Set fieldNameRange = srcTable.Rows(1)
    
    'フィールド名の範囲を0基底の配列に変換
    fieldNameArray = Application.Transpose(Application.Transpose(fieldNameRange))
    ReDim fieldNameArray0(0 To UBound(fieldNameArray) - 1)
    For i = 0 To UBound(fieldNameArray0)
      fieldNameArray0(i) = fieldNameArray(i + 1)
    Next i
       
    makeTable GetDesktopPath & "\SampleDataBase.mdb", "refList", Array("郵便番号")
    '接続オープン
    Set cn = New ADODB.Connection
    cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & GetDesktopPath & "\SampleDataBase.mdb;"
    cn.Execute "delete * from zipCodeTable;"
    starttime = GetTickCount
    
    Set rs = New ADODB.Recordset
    '郵便番号辞書をテーブルに書き出し 'adOpenStaticは遅い
    rs.Open "zipCodeTable", cn, adOpenDynamic, adLockOptimistic
    For i = 2 To UBound(srcArray, 1)
      rs.AddNew
      For j = 1 To fieldNameRange.Columns.Count
            rs.Fields(j - 1).Value = srcArray(i, j)
      Next j
      rs.Update
    Next i
    rs.Close

terminate:
    On Error Resume Next
    rs.Close: Set rs = Nothing
    cn.Close: Set cn = Nothing
  Debug.Print CStr(GetTickCount - starttime)
End Sub