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


エクセルの列(数~十数万行)からユニークなリストを高速に取り出す

QAサイトの高速化ネタが、投稿前に閉じられてしまったので、まとめておきます。
テストデータとして、日本郵政のホームページからダウンロード出来る郵便番号辞書を使う事を教わったので、使っています。
平成25年10月31日更新の「読み仮名データの促音・拗音を小書きで表記するもの」というもので、123427行あります。(惜しい!)
Sheet(1)の都道府県名の列から、Sheet(2)に抽出しています。※連想配列はセル→配列に取り込む高速化を併用しています
結果 

No 方法 結果(msec) 倍数  
1 連想配列(Dictionary)※   200 -  
2 ADO 1273 6  
3 フィルタオプション 81500 400  
4 COUNTIF + オートフィルタ リソース不足 -  

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