Option Explicit
Declare Function GetTickCount Lib "kernel32" () As Long
'*******************************************************************************
' 参照設定:Microsoft ADO Ext x.x for DDL and Security
' Microsoft Active Data Objects x.x Library
'*******************************************************************************
'Sheet1!$A$1:$O$123428 2013年頃取り込んだ郵便番号データ 12万行、3列目が郵便番号
'Sheet4のA列に1000件の抽出する郵便番号リスト
'Sheet5に抽出
'==============================================
'AutoFilterのCriteriaに配列を指定
'265msec
'==============================================
Sub autoFilterMethod2()
Dim myTable As Range
Dim starttime As Long
Dim refTable() As Variant
Dim i As Long
Dim destRange As Range, refRange As Range
starttime = GetTickCount
'この様な一括貼り付けでも画面更新停止は有効
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set myTable = Sheets("Sheet1").Range("A1").CurrentRegion
'コピー先
Set destRange = Sheets("Sheet5").Range("A1")
'抽出するキーのリスト 1000行
'一行目はフィールド名
Set refRange = Sheets("Sheet4").Range("A1").CurrentRegion
'抽出条件を0基底の配列にコピー
ReDim refTable(0 To refRange.Rows.Count - 2)
For i = 2 To refRange.Rows.Count
refTable(i - 2) = CStr(refRange.Cells(i, 1).Value)
Next i
'Operator:=xlFilterValuesを指定しないと配列の最後の要素しか使われない
'Web検索してみると、世の中には他にもはまった人がいて助かった
myTable.AutoFilter Field:=3, Criteria1:=refTable, Operator:=xlFilterValues
myTable.SpecialCells(Type:=xlCellTypeVisible).Copy Destination:=destRange
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Debug.Print CStr(GetTickCount - starttime)
End Sub
コンテンツリストに戻る
'==============================================
'既存mdbに抽出条件のテーブル書き出し、クエリ実行、ワークシートに貼り付け
'500msec 1256records
'==============================================
Sub execQuery()
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
starttime = GetTickCount
Set srcTable = Sheets("Sheet1").Range("A1").CurrentRegion
srcArray = srcTable.Value
Set fieldNameRange = srcTable.Rows(1)
'接続を一旦開いてテーブルをドロップ
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & GetDesktopPath & "\SampleDataBase.mdb;"
cn.Execute "DROP TABLE reflist"
cn.Close
makeTable GetDesktopPath & "\SampleDataBase.mdb", "refList", Array("郵便番号")
'接続オープン
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & GetDesktopPath & "\SampleDataBase.mdb;"
Set rs = New ADODB.Recordset
'参照リストをテーブルに書き出し
refArray = Sheets("Sheet4").Range("A1").CurrentRegion.Value
rs.Open "refList", cn, adOpenKeyset, adLockOptimistic
'一行目はフィールド名
For i = 2 To UBound(refArray, 1)
rs.AddNew
rs.Fields(0).Value = refArray(i, 1)
rs.Update
Next i
rs.Close
'クエリ実行
rs.Open "SELECT * FROM zipCodeTable INNER JOIN refList ON zipCodeTable.郵便番号 = refList.郵便番号;", cn
Sheets("Sheet5").Range("A1").CopyFromRecordset rs
terminate:
On Error Resume Next
rs.Close: Set rs = Nothing
cn.Close: Set cn = Nothing
Debug.Print CStr(GetTickCount - starttime)
End Sub
コンテンツリストに戻る
'==============================================
'WorkSheet間でINNER JOIN Jet 4.0 プロバイダ
'655 msec
'==============================================
’速いけれど、Jet 4.0プロバイダを開いているエクセルブックに使用すると
'メモリリークでやがてExcelがフリーズするというバグがあります。
'BUG: Memory leak occurs when you query an open Excel worksheet by using ActiveX Data Objects (ADO)
'https://support.microsoft.com/en-us/kb/319998
'対策としては次の二つが記載されています
'1) Use the SELECT INTO syntax of the Jet OLE DB Provider to export the Excel data to a new worksheet.
’ SELECT INTOのSQLを用いて、新しいワークシートに書き込めば良いらしい。⇒ 色々トライしてみましたが、動作しませんでした。
'2) Use the SaveCopyAs method of the Workbook object... SaveCopyAsでコピーを保存して、そちらを操作。
Sub runsql_on_ws_jet4()
Dim starttime As Long
Dim refTable As Variant
Dim destRange As Range
Dim objCn As ADODB.Connection
Dim objRS As ADODB.Recordset
Dim strSQL As String
starttime = GetTickCount
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'Sheet1!$A$1:$O$123428 2013年頃取り込んだ郵便番号辞書 12万行、3列目が郵便番号
'コピー先
Set destRange = Sheets("Sheet5").Range("A1")
Set objCn = New ADODB.Connection
With objCn
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("Extended Properties") = "Excel 8.0"
.Open ThisWorkbook.Path & "\" & ThisWorkbook.Name
End With
strSQL = "SELECT * FROM [Sheet1$] AS A INNER JOIN [Sheet4$] AS B ON A.郵便番号=B.郵便番号;"
Set objRS = New ADODB.Recordset
' Set objRS = objCn.Execute(strSQL) こちらでも同じ
objRS.Open strSQL, objCn
', adOpenDynamic, adLockOptimistic このオプションを付けると50msec位遅くなる
destRange.CopyFromRecordset objRS
objCn.Close
Set objCn = Nothing
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Debug.Print CStr(GetTickCount - starttime)
End Sub
コンテンツリストに戻る
'==============================================
'WorkSheet間でINNER JOIN ace 12.0 プロバイダ
'2090 msec
'==============================================
Sub runsql_on_ws_jet12()
Dim starttime As Long
Dim destRange As Range
Dim objCn As ADODB.Connection
Dim objRS As ADODB.Recordset
Dim strSQL As String
starttime = GetTickCount
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'Sheet1!$A$1:$O$123428 2013年頃取り込んだ郵便番号辞書 12万行、3列目が郵便番号
'コピー先
Set destRange = Sheets("Sheet5").Range("A1")
Set objCn = New ADODB.Connection
With objCn
.Provider = "Microsoft.ace.OLEDB.12.0"
.ConnectionString = "Data Source=" & ThisWorkbook.FullName & ";" & _
"Extended Properties='Excel 12.0; HDR=Yes'"
.Open
End With
strSQL = "SELECT * FROM [Sheet1$] AS A INNER JOIN [Sheet4$] AS B ON A.郵便番号=B.郵便番号;"
Set objRS = New ADODB.Recordset
Set objRS = objCn.Execute(strSQL)
destRange.CopyFromRecordset objRS
objCn.Close
Set objCn = Nothing
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Debug.Print CStr(GetTickCount - starttime)
End Sub
コンテンツリストに戻る
'==============================================
'Dictionaryに配列を収納する事で重複対応
'2605msec
'==============================================
Sub myDic()
Dim myDic As Object
Dim myCell As Range, myTable As Range
Dim srcColumn As Variant
Dim starttime As Long
Dim refTable As Variant
Dim i As Long, j As Long, k As Long
Dim destRange As Range
Dim myKey As String
Dim tempArray As Variant
starttime = GetTickCount
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'Sheet1!$A$1:$O$123428 2013年頃取り込んだ郵便番号辞書 12万行、3列目が郵便番号
Set myTable = Sheets("Sheet1").Range("A1").CurrentRegion
'郵便番号辞書の3列目を配列に取込
srcColumn = myTable.Columns(3).Value
Set myDic = CreateObject("Scripting.Dictionary")
'コピー先
Set destRange = Sheets("Sheet5").Range("A1")
For i = 2 To UBound(srcColumn, 1)
myKey = CStr(srcColumn(i, 1))
If myDic.exists(myKey) Then
If IsArray(myDic(myKey)) Then
tempArray = myDic.Item(myKey)
k = UBound(tempArray)
ReDim Preserve tempArray(k + 1)
tempArray(k + 1) = i
myDic.Item(myKey) = tempArray
Else
myDic.Item(myKey) = Array(myDic(myKey), i)
End If
Else
myDic(myKey) = i
End If
Next i
'抽出するキーのリスト 1000行
'一行目はフィールド名
refTable = Sheets("Sheet4").Range("A1").CurrentRegion.Value
For i = 2 To UBound(refTable, 1)
myKey = CStr(refTable(i, 1))
If IsArray(myDic(myKey)) Then
For j = 0 To UBound(myDic(myKey))
myTable.Rows(myDic(myKey)(j)).Copy Destination:=destRange
Set destRange = destRange.Offset(1, 0)
Next j
Else
myTable.Rows(myDic(myKey)).Copy Destination:=destRange
Set destRange = destRange.Offset(1, 0)
End If
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Debug.Print CStr(GetTickCount - starttime)
End Sub
コンテンツリストに戻る
'==============================================
'テンポラリmdb作成、テーブル作成、クエリ実行
'トランザクションをしなくても12万件一気に書き込めた
'9454msec
'==============================================
Sub makeMdbAndExecQuery()
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
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)
For i = 0 To UBound(fieldNameArray0)
fieldNameArray0(i) = fieldNameArray(i + 1)
Next i
'手抜きでエラー処理していない、本来戻り値が0以外ならExitすべき。
makeMdb GetDesktopPath & "\SampleDataBase.mdb"
makeTable GetDesktopPath & "\SampleDataBase.mdb", "zipCodeTable", fieldNameArray0
makeTable GetDesktopPath & "\SampleDataBase.mdb", "refList", Array("郵便番号")
'接続オープン
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & GetDesktopPath & "\SampleDataBase.mdb;"
Set rs = New ADODB.Recordset
'郵便番号辞書をテーブルに書き出し
rs.Open "zipCodeTable", cn, adOpenKeyset, 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
'参照リストをテーブルに書き出し
refArray = Sheets("Sheet4").Range("A1").CurrentRegion.Value
rs.Open "refList", cn, adOpenKeyset, adLockOptimistic
'一行目は見出し
For i = 2 To UBound(refArray, 1)
rs.AddNew
rs.Fields(0).Value = refArray(i, 1)
rs.Update
Next i
rs.Close
'クエリ実行
rs.Open "SELECT * FROM zipCodeTable INNER JOIN refList ON zipCodeTable.郵便番号 = refList.郵便番号;", cn
Sheets("Sheet5").Range("A1").CopyFromRecordset rs
terminate:
On Error Resume Next
rs.Close: Set rs = Nothing
cn.Close: Set cn = Nothing
Debug.Print CStr(GetTickCount - starttime)
End Sub
コンテンツリストに戻る
'==============================================
'ワークシート関数のMatchを使用 Findに比べると10倍速
'20717msec
'==============================================
Sub matchMethod()
Dim myTable As Range, dataArea As Range
Dim srcColumn As Variant
Dim starttime As Long
Dim refTable As Variant
Dim i As Long
Dim destRange As Range, myColumn As Range, myArea As Range
Dim hitRowNo As Long
Dim ret As Variant
starttime = GetTickCount
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'Sheet1!$A$1:$O$123428 2013年頃取り込んだ郵便番号辞書 12万行、3列目が郵便番号
Set myTable = Sheets("Sheet1").Range("A1").CurrentRegion
Set dataArea = Intersect(myTable, myTable.Offset(1, 0))
'コピー先
Set destRange = Sheets("Sheet5").Range("A1")
'抽出するキーのリスト 1000行
'一行目はフィールド名
refTable = Sheets("Sheet4").Range("A1").CurrentRegion.Value
For i = 2 To UBound(refTable, 1)
Set myColumn = dataArea.Columns(3)
Do
'Application.Worksheetfunction.Matchだと、空振りの時実行時エラーになる
ret = Application.Match(refTable(i, 1), myColumn, 0)
If IsError(ret) Then
Exit Do
Else
dataArea.Rows(ret).Copy destRange
Set destRange = destRange.Offset(1, 0)
Set myColumn = myColumn.Offset(ret, 0).Resize(myColumn.Rows.Count - ret, 1)
End If
Loop
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Debug.Print CStr(GetTickCount - starttime)
End Sub
コンテンツリストに戻る
'==============================================
'フィルターオプション(AdvancedFilter) コードはスッキリだが意外と遅い
'29391msec
'==============================================
Sub advancedFilterMethod()
Dim myCell As Range, myTable As Range, dataArea As Range
Dim srcColumn As Variant
Dim starttime As Long
Dim refTable As Range
Dim i As Long
Dim destRange As Range, myRow As Range, myArea As Range
starttime = GetTickCount
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'Sheet1!$A$1:$O$123428 2013年頃取り込んだ郵便番号辞書 12万行、3列目が郵便番号
Set myTable = Sheets("Sheet1").Range("A1").CurrentRegion
Set dataArea = Intersect(myTable, myTable.Offset(1, 0))
'コピー先
Set destRange = Sheets("Sheet5").Range("A1")
'抽出するキーのリスト 1000行
Set refTable = Sheets("Sheet4").Range("A1").CurrentRegion
myTable.AdvancedFilter Action:=xlFilterCopy, criteriarange:=refTable, copytorange:=destRange, unique:=False
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Debug.Print CStr(GetTickCount - starttime)
End Sub
コンテンツリストに戻る
'==============================================
'12万件と、1000件をメモリに取り込んで比較ループを回す
'ヒットした行を別のVariant配列に書き込んで一括貼り付け
'30467msec
'==============================================
Sub onMemoryLoop2()
Dim myCell As Range, myTable As Range
Dim srcTable As Variant
Dim starttime As Long
Dim refTable As Variant
Dim i As Long, j As Long, k As Long, counter As Long
Dim destRange As Range
Dim myKey As String
Dim tempArray As Variant
starttime = GetTickCount
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'Sheet1!$A$1:$O$123428 2013年頃取り込んだ郵便番号辞書 12万行、3列目が郵便番号
Set myTable = Sheets("Sheet1").Range("A1").CurrentRegion
'見出し行カット
Set myTable = Intersect(myTable, myTable.Offset(1, 0))
'郵便番号辞書を配列に取込
srcTable = myTable.Value
'一次元目はRedim Preserveで拡張できないので余裕をみて貼り付け先配列を確保
'コピー先セル配列及びVariant配列
Set destRange = Sheets("Sheet5").Range("A1").Resize(10000, myTable.Columns.Count)
tempArray = destRange.Value
counter = 1
'抽出するキーのリスト 1000行
'一行目はフィールド名
refTable = Sheets("Sheet4").Range("A1").CurrentRegion.Value
For i = 2 To UBound(refTable, 1)
For j = 1 To UBound(srcTable, 1)
If refTable(i, 1) = srcTable(j, 3) Then
For k = 1 To UBound(tempArray, 2)
tempArray(counter, k) = srcTable(j, k)
Next k
counter = counter + 1
End If
Next j
Next i
'これ以降は200msec以下しかかかっていないので、3重ループが遅いらしい
'emptyの値はセルに貼り付けても空でうるさくない
destRange.Value = tempArray
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Debug.Print CStr(GetTickCount - starttime)
End Sub
コンテンツリストに戻る
'==============================================
'12万件と、1000件をメモリに取り込んで比較ループを回す
'ヒットした行をコピー
'12万件の表の1列しかメモリに展開しないので容量的には有利か。結構速い。
'32885msec
'==============================================
Sub onMemoryLoop()
Dim myCell As Range, myTable As Range
Dim srcColumn As Variant
Dim starttime As Long
Dim refTable As Variant
Dim i As Long, j As Long, k As Long
Dim destRange As Range
Dim myKey As String
Dim tempArray As Variant
starttime = GetTickCount
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'Sheet1!$A$1:$O$123428 2013年頃取り込んだ郵便番号辞書 12万行、3列目が郵便番号
Set myTable = Sheets("Sheet1").Range("A1").CurrentRegion
'見出し行カット
Set myTable = Intersect(myTable, myTable.Offset(1, 0))
'郵便番号辞書の3列目を配列に取込
srcColumn = myTable.Columns(3).Value
'コピー先
Set destRange = Sheets("Sheet5").Range("A1")
'抽出するキーのリスト 1000行
'一行目はフィールド名
refTable = Sheets("Sheet4").Range("A1").CurrentRegion.Value
For i = 2 To UBound(refTable, 1)
For j = 1 To UBound(srcColumn, 1)
If refTable(i, 1) = srcColumn(j, 1) Then
myTable.Rows(j).Copy Destination:=destRange
Set destRange = destRange.Offset(1, 0)
End If
Next j
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Debug.Print CStr(GetTickCount - starttime)
End Sub
コンテンツリストに戻る
'==============================================
'AutoFilterに1000行個別に条件を設定する
'56160msec
'==============================================
Sub autoFilterMethod()
Dim myCell As Range, myTable As Range, dataArea As Range
Dim srcColumn As Variant
Dim starttime As Long
Dim refTable As Variant
Dim i As Long
Dim destRange As Range, myRow As Range, myArea As Range
starttime = GetTickCount
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'Sheet1!$A$1:$O$123428 2013年頃取り込んだ郵便番号辞書 12万行、3列目が郵便番号
Set myTable = Sheets("Sheet1").Range("A1").CurrentRegion
Set dataArea = Intersect(myTable, myTable.Offset(1, 0))
'コピー先
Set destRange = Sheets("Sheet5").Range("A1")
'抽出するキーのリスト 1000行
'一行目はフィールド名
refTable = Sheets("Sheet4").Range("A1").CurrentRegion.Value
For i = 2 To UBound(refTable, 1)
myTable.AutoFilter Field:=3, Criteria1:=refTable(i, 1)
For Each myArea In dataArea.SpecialCells(Type:=xlCellTypeVisible).Areas
myArea.Copy Destination:=destRange
Set destRange = destRange.Offset(myArea.Rows.Count, 0)
Next myArea
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Debug.Print CStr(GetTickCount - starttime)
End Sub
コンテンツリストに戻る
'==============================================
'onMemoryRecordset 速いとは思わなかったがネタでやってみた
'93320msec
'==============================================
Sub onMemoryRecordset()
Dim myTable As Range, fieldNameRange As Range
Dim srcTable As Variant
Dim starttime As Long
Dim refTable As Variant
Dim i As Long, j As Long, k As Long, counter As Long
Dim destRange As Range
Dim myKey As String
Dim tempArray As Variant
Dim rs As ADODB.Recordset
starttime = GetTickCount
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'Sheet1!$A$1:$O$123428 2013年頃取り込んだ郵便番号辞書 12万行、3列目が郵便番号
Set myTable = Sheets("Sheet1").Range("A1").CurrentRegion
Set fieldNameRange = myTable.Rows(1)
'見出し行カット
Set myTable = Intersect(myTable, myTable.Offset(1, 0))
'郵便番号辞書を配列に取込
srcTable = myTable.Value
'コピー先
Set destRange = Sheets("Sheet5").Range("A1")
Set rs = New ADODB.Recordset
With rs
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockOptimistic
End With
With rs
For i = 1 To fieldNameRange.Columns.Count
.Fields.Append fieldNameRange.Cells(i), adVarChar, 255
Next i
End With
With rs
.Open
For i = 1 To UBound(srcTable, 1)
.AddNew
For j = 1 To UBound(srcTable, 2)
.Fields(j - 1).Value = srcTable(i, j)
Next j
.Update
Next i
End With
rs.MoveFirst
'抽出するキーのリスト 1000行
'一行目はフィールド名
refTable = Sheets("Sheet4").Range("A1").CurrentRegion.Value
For j = 2 To UBound(refTable)
rs.Filter = "郵便番号='" & refTable(j, 1) & "'"
destRange.CopyFromRecordset rs
Set destRange = destRange.Offset(rs.RecordCount, 0)
rs.Filter = ""
Next j
rs.Close
Set rs = Nothing
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Debug.Print CStr(GetTickCount - starttime)
End Sub
コンテンツリストに戻る
'==============================================
'Find&FindNextを1000回やってみる
'217887msec
'==============================================
Sub findMethod()
Dim myCell As Range, myTable As Range
Dim srcColumn As Variant
Dim starttime As Long
Dim refTable As Variant
Dim i As Long
Dim destRange As Range, hitRange As Range
Dim firstAddress As String
starttime = GetTickCount
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'Sheet1!$A$1:$O$123428 2013年頃取り込んだ郵便番号辞書 12万行、3列目が郵便番号
Set myTable = Sheets("Sheet1").Range("A1").CurrentRegion
'コピー先
Set destRange = Sheets("Sheet5").Range("A1")
'抽出するキーのリスト 1000行
'一行目はフィールド名
refTable = Sheets("Sheet4").Range("A1").CurrentRegion.Value
For i = 2 To UBound(refTable, 1)
Set hitRange = myTable.Columns(3).Find(What:=refTable(i, 1) _
, After:=myTable.Cells(1, 3) _
, LookIn:=xlValues _
, LookAt:=xlWhole _
, SearchOrder:=xlByColumns _
, SearchDirection:=xlNext _
, MatchCase:=True _
, MatchByte:=True _
, SearchFormat:=False)
If Not hitRange Is Nothing Then
'最初のセルのアドレスを覚える
firstAddress = hitRange.Address
'繰返し検索し、条件を満たすすべてのセルを検索する
Do
myTable.Rows(hitRange.Row).Copy Destination:=destRange
Set destRange = destRange.Offset(1, 0)
Set hitRange = myTable.Columns(3).FindNext(hitRange)
If hitRange Is Nothing Then Exit Do
Loop Until hitRange.Address = firstAddress
End If
firstAddress = ""
Set hitRange = Nothing
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Debug.Print CStr(GetTickCount - starttime)
End Sub
コンテンツリストに戻る
'==============================================
'ワークシートでADO,参照リストの1行毎にSQL実行、劇遅
'ADO 1539792msec 1540sec 25.7min
'==============================================
'あまり役に立たない情報 - どうしてこんなに遅いの？内部結合は速いのに．．．と検討してみました。
'Jet 4.0 Providerを使うと、処理時間は1/3弱になりましたが、十分遅い
'CursorLocationがadUseClientである影響はと、Defalutに戻してやってみましたが、僅かに速くなった程度でした。
'adOpenDynamicを止めると10%位速くなりました。
'ステップ毎に実行させてみると、Recordset1個取得に千数百msecかかっています。内部結合クエリで一発で抽出するのと
'大して違わない時間がかかっている事が分かりました。それを千回も繰り返したら遅いわけです。
Sub worksheetADO()
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim starttime As Long
Dim refTable As Variant
Dim i As Long
Dim destRange As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
starttime = GetTickCount
Set cn = New 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
Set rs = New ADODB.Recordset
rs.CursorLocation = adUseClient
Set destRange = Sheets("Sheet5").Range("A1")
refTable = Sheets("Sheet4").Range("A1").CurrentRegion.Value
For i = 2 To UBound(refTable, 1)
rs.Open "select * from [Sheet1$] where 郵便番号='" & refTable(i, 1) & "'", cn, adOpenDynamic
destRange.CopyFromRecordset rs
Set destRange = destRange.Offset(rs.RecordCount, 0)
rs.Close
Next i
On Error Resume Next
rs.Close: Set rs = Nothing
cn.Close: Set cn = Nothing
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = False
Debug.Print CStr(GetTickCount - starttime)
End Sub
'==============================================
' 以下はサブルーチン集
'==============================================
'mdb作成に成功したら0を戻す。失敗ならエラーコード
Function makeMdb(mdbFullPath 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.Jet.OLEDB.4.0;Data Source="
cat.Create ConnectionString & mdbFullPath & ";"
Set cat = Nothing
errHandle:
makeMdb = Err.Number
End Function
'table作成に成功したら0を戻す。失敗ならエラーコード
Function makeTable(mdbFullPath As String, tableName As String, fieldNameArray As Variant)
Dim cat As ADOX.Catalog
Dim tbl As ADOX.Table
Dim ConnectionString As String
Dim con As ADODB.Connection
Dim srcTable As Range, fieldNameRange As Range
Dim i As Long
Dim objKey As ADOX.Key
On Error GoTo errHandle
Set srcTable = Sheets("Sheet1").Range("A1").CurrentRegion
Set fieldNameRange = srcTable.Rows(1)
Set cat = New ADOX.Catalog
Set objKey = New ADOX.Key
ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="
Set con = New ADODB.Connection
con.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & mdbFullPath & ";"
cat.ActiveConnection = con
Set tbl = New ADOX.Table
tbl.Name = tableName
Set tbl.ParentCatalog = cat
'簡便のため全て文字列型、最大長
For i = 0 To UBound(fieldNameArray)
tbl.Columns.Append fieldNameArray(i), adVarWChar, 255
Next i
cat.Tables.Append tbl
Set tbl = Nothing
Set cat = Nothing
errHandle:
makeTable = Err.Number
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