エクセルVBA 重複データから１種類ずつ抽出

いつもお世話になります。
５万行のエクセルデータで、A列に２０種類のデータが重複しています。
このデータを、別シートのA１～A２０に１種類ずつコピーしたいのです。
オートフィルタ→フィルタオプション→重複するレコードは無視するでチャレンジしてみたのですが、５万行だとデータ量の関係で時間がかかりすぎるので、VBAでもっと短時間で出来ないかと思い、投稿させていただきました。

よろしくお願いいたします。

No.5 ベストアンサー 回答者： mitarashi 回答日時： 2013/07/25 22:38

フィルタオプションによる抽出は速いという印象がありましたが、ユニークなデータ抽出は劇遅ですね。

50000行のデータで終わるまで待てないで無理矢理終了させてしまいました。
この手の処理は連想配列が速いです。標準で機能を持っている言語もありますが、VBAの場合は別の（といってもWindowsが標準で持っている）ActiveXのお世話になる必要があります。下記のコードは、セル操作を最小限に止めるために配列に収納して操作する高速化の技も併用していますが、A列に5万行、乱数で作成したアルファベット2文字の文字列のユニークなリスト取り出しが100msec弱で処理できました。（Windows7Home(64bit), xl2010, Core i5 3.2GHz)
ご参考まで。
なお、APIは時間計測に使っているだけですので、気にしないで下さい。

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

Sub test()
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
Set targetRange = Sheets("Sheet1").Range("A1:A50000")
buf = targetRange
Set myDic = CreateObject("Scripting.Dictionary")
On Error Resume Next
For i = 1 To 50000
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
MsgBox CStr(GetTickCount - startTime) & "msec"
End Sub

この回答へのお礼

ご回答ありがとうございます。うまくいきました。
まだ意味は理解できていませんが、咀嚼して活用できるようにしたいと思います。

お礼日時：2013/07/26 13:05

No.6 回答者： nicotinism 回答日時： 2013/07/26 09:29

Dictionary オブジェクト速いですね。

当方でも日本郵便の郵便番号データの町域部分で試したところ、
データ数、124,300件、（Excel2010）で
抽出件数：86,117件
ADO→1825ms
Dictionary→1061ms
でした。
都道府県部分だと
ADO→1217ms
Dictionary→172ms

ファイル形式（xls、xlsm）やExcelのバージョンに配慮する必要がないので
#5さんの方法をお勧めします。

No.4 回答者： KURUMITO 回答日時： 2013/07/25 14:04

マクロを使うことが計算速度を速めることにはならないでしょう。

むしろ関数などによる対応がおすすめです。
データがA2セルから下方の行に入力されているとします。
作業列としてB列のB２セルには次の式を入力します。

=IF(A2="","",IF(COUNTIF(A$2:A2,A2)=1,MAX(B$1:B1)+1,""))

その後にB２セルを選択したのちに「コピー」します。
名前ボックスがB２と表示されているでしょう。その窓をB2:B50000ように変更して確定します。
B２セルからB５００００セルまでが範囲として選択されますので右クリックして「貼り付け」を選択します。
お求めの表をシート２に表示させるとしてA２セルには次の式を入力して下方にドラッグコピーします。

=IF(ROW(A1)>MAX(Sheet1!B:B),"",INDEX(Sheet1!A:A,MATCH(ROW(A1),Sheet1!B:B,0)))

この回答へのお礼

ご回答ありがとうございます。
なるほどです。関数でここまでのことが出来るとは思いもよらなかったです。
別のシチュエーションで、自分程度のあたまでここまで思いつくかどうかという問題はあるものの、非常に参考になりました！
ありがとうございました。

お礼日時：2013/07/26 13:06

No.3 回答者： FEX2053 回答日時： 2013/07/25 13:33

#2さんのやり方なら速くなるかも（Excelの本来の機能じゃない、

Officeが持ってるデータベース処理の機能を使っているので）。
この辺はこれが参考になるかな？
http://support.microsoft.com/kb/246335/ja

ただ、うまく動かないときにどうするかは、↑でわかるように結構
スキルが必要なので、どうしようもない場合だけ使った方がいい
と思います。

この回答へのお礼

度々のご回答ありがとうございました。
教えていただいたURLに目を通しましたが、まさにこれですね。
頑張ってやってみます。
ありがとうございました。

お礼日時：2013/07/26 13:20

No.2 回答者： nicotinism 回答日時： 2013/07/25 12:54

Excelのバージョンが不明ですが 2007以降なら

Sub test()
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset

Set cn = New ADODB.Connection
With cn
.Provider = "Microsoft.ace.OLEDB.12.0"
.ConnectionString = "Data Source=" & ThisWorkbook.FullName & ";" & _
"Extended Properties='Excel 12.0; HDR=No'"
.Open
End With

Set rs = New ADODB.Recordset
rs.Open "select distinct f1 from [Sheet1$] ", cn, adOpenDynamic
Sheets(2).Cells(1, 1).CopyFromRecordset rs

cn.Close: Set cn = Nothing

End Sub

でシート２に書き込まれるかも？

この回答へのお礼

ご回答ありがとうございます。うまくいきました。
まだVBAの意味は理解できていませんが、咀嚼して活用できるようにしたいと思います。

お礼日時：2013/07/26 13:07

No.1 回答者： FEX2053 回答日時： 2013/07/25 11:55

いや、VBAはインタプリタ言語ですし、そもそも処理速度は

Excelの持つ関数やウィザードなどより確実に遅いですよ。

ですので、VBAで書き直すなら、抽出とはまったく違った
ロジックを考える必要があります。逆に言えば、簡単に処理
できるロジックに気づかないなら、そのままフィルタオプション
を使った方が速いってことです。

つか、Excelは2007以降でも、データ量が1万件を超えると
処理速度が極端に落ちます。データ量が5万件もあるなら
Aceessにデータ移行して、Accessのクエリを動作させた方が
処理速度も安定性も、格段に上ですよ。

Excelは1万件までのデータ処理ソフトだと思った方がいいです。

この回答への補足

早速のご回答ありがとうございます。
ただ、このデータはどうしてもエクセルで処理せざるを得ず、（同じ会社の人のPCにアクセスが入っていない場合があり、そのPCでも作業する必要があるので）また、例えばオートフィルタをその列にかければ、プルダウンメニューから２０種類全てのデータが見えますよね。だからその要件自体はVBAであればすぐ解決できるのかなって思ったんですけど・・・。

自分でも本を読んでみたのですが、そのような機能が見当たらず、お聞きした次第です。

もし、無いようならご指摘のとおり時間がかかってもウィザードで対応しようと思います。

補足日時：2013/07/25 13:00