GDIplusCODE


Private Declare Function GetTickCount Lib "kernel32" () As Long

'199.6 msec
Sub myDictionary()
  Dim targetRange As Range, destRange As Range
  Dim buf As Variant, buf2 As Variant
  Dim myDic As Object
  Dim i As Long
  Dim myKeys As Variant
  Dim startTime As Long
  
  startTime = GetTickCount
'20msec位かかるのでDictionaryとADOでは不要
'  Application.ScreenUpdating = False

  Sheets("Sheet2").Cells.Clear
  With Sheets("Sheet1")
    Set targetRange = .Range(.Range("G2"), .Range("G" & .Rows.Count).End(xlUp))
  End With
  buf = targetRange
  Set myDic = CreateObject("Scripting.Dictionary")
  On Error Resume Next
  For i = 1 To targetRange.Rows.Count
    myDic.Add buf(i, 1), ""
  Next i
  On Error GoTo 0
  With Sheets("Sheet2")
    Set destRange = .Range(.Range("A1"), .Range("A" & myDic.Count))
  End With
  buf2 = destRange
  myKeys = myDic.keys
  For i = 1 To myDic.Count
    buf2(i, 1) = myKeys(i - 1)
  Next i
  destRange = buf2
'  Application.ScreenUpdating = True

  Debug.Print CStr(GetTickCount - startTime)
End Sub

'ADO 1272.8 msec(連想配列の6倍かかる)
Sub myADO()
  Dim cn As ADODB.Connection
  Dim rs As ADODB.Recordset
  Dim startTime As Long
  
  Sheets("Sheet2").Cells.Clear
  startTime = GetTickCount
'  Application.ScreenUpdating = False

  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.Open "select distinct 都道府県 from [Sheet1$] ", cn, adOpenDynamic
  Sheets(2).Cells(1, 1).CopyFromRecordset rs
  
  cn.Close: Set cn = Nothing
'  Application.ScreenUpdating = True

  Debug.Print CStr(GetTickCount - startTime)
End Sub

'81500 msec程度(連想配列の400倍かかる)
Sub myAdvancedFilter()
  Dim startTime As Long
  Dim targetRange As Range
  
  Sheets("Sheet2").Cells.Clear
  startTime = GetTickCount
  Application.ScreenUpdating = False
  With Sheets("Sheet1")
    Set targetRange = .Range(.Range("G1"), .Range("G" & .Rows.Count).End(xlUp))
  End With
  targetRange.AdvancedFilter Action:=xlFilterInPlace, unique:=True
  targetRange.Copy Sheets("Sheet2").Range("A1")
  Sheets("Sheet1").ShowAllData
  Application.ScreenUpdating = True

  Debug.Print CStr(GetTickCount - startTime)
End Sub

'そこそこ速かった記憶はあるが、データが多すぎるとNG
Sub myCOUNTIF()
  Dim targetRange As Range, destRange As Range
  Dim buf As Variant, buf2 As Variant
  Dim myDic As Object
  Dim i As Long
  Dim myKeys As Variant
  Dim startTime As Long
  
  startTime = GetTickCount
  Application.ScreenUpdating = False
  With Sheets("Sheet1")
    Set targetRange = .Range(.Range("G2"), .Range("G" & .Rows.Count).End(xlUp))
  End With
  targetRange.Offset(, 9).FormulaR1C1 = "=COUNTIF(R2C[-9]:RC[-9],RC[-9])"
  'ここでリソース不足のエラーとなる
  targetRange.Offset(, 9).Value = targetRange.Offset(, 9).Value
  
  '1でオートフィルタをかけて、Sheet2にコピーする構想
  
  Application.ScreenUpdating = True
  MsgBox CStr(GetTickCount - startTime) & "msec"
End Sub
No	方法	結果(msec)	倍数
1	連想配列(Dictionary)※	200	-
2	ADO	1273	6
3	フィルタオプション	81500	400
4	COUNTIF + オートフィルタ	リソース不足	-
エクセルの列（数～十数万行）からユニークなリストを高速に取り出す
