【Excel】【VBA】 効率の良いカウント処理について

以下(1)のようなデータがあります。※実際はもっと項目数は多いです。
(1)を元に、別シートに(2)のような集計を出したいのですが、
数式を埋め込みたくないため、VBAでカウントさせて実データを埋め込みたいです。

(1)　　Ａ　　　　Ｂ
｜　名前　｜　出身　｜
├────┼────┤
｜　田中　｜　岩手　｜
｜　吉田　｜　秋田　｜
｜　井上　｜　沖縄　｜
｜　加藤　｜　島根　｜
｜　鈴木　｜　岐阜　｜
｜　木本　｜　愛知　｜
｜　伊藤　｜　沖縄　｜
｜　宮田　｜　秋田　｜
｜　佐藤　｜　長野　｜

　　　　↓↓↓
(2)　　Ａ　　　　Ｂ
｜　出身　｜　人数　｜
├────┼────┤
｜　岩手　｜　　１　｜
｜　秋田　｜　　２　｜
｜　沖縄　｜　　２　｜
｜　島根　｜　　１　｜
｜　岐阜　｜　　１　｜
｜　愛知　｜　　１　｜
｜　長野　｜　　１　｜

そこで以下のように書いてみたところ、正しくカウントは取れるのですが、
思った以上に処理時間がかかってしまいました。

Dim dc1 As Integer
Dim dc2 As Integer
dc1 = Worksheets("Sheet1").Range("A65536").End(xlUp).Row
dc2 = Worksheets("Sheet2").Range("A65536").End(xlUp).Row
i1 = 0
i2 = 0
For i1 = 2 To dc2
cnt = 0
For i2 = 2 To dc1
If Worksheets("Sheet2").Cells(i1, 1) = Worksheets("Sheet1").Cells(i2, 1) Then
cnt = cnt + 1
End If
Next i2
Worksheets("Sheet2").Cells(i1, 2) = cnt
cntRec = cntRec + 1
Application.StatusBar = "件数処理実行中・・・(現在 " & cntRec & "件)"
Next i1

(1)を元に(2)のような表を作成するのに、もっと処理時間が短くなるような
書き方はありますでしょうか？よろしくお願いいたします。

No.3 ベストアンサー 回答者： lotilyxoen 回答日時： 2009/08/22 04:15

Public Sub ToDoHuKen()

Dim dc1 As Integer, dc2 As Integer
Dim i1 As Integer, cnt As Integer
dc1 = Worksheets("Sheet1").Range("A65536").End(xlUp).Row
dc2 = Worksheets("Sheet2").Range("A65536").End(xlUp).Row

For i1 = 2 To dc2
cnt = 0
'組み込み関数を使ったほうが速い
cnt = WorksheetFunction.CountIf(Worksheets("Sheet1").Range("A2:A" & dc1), Worksheets("Sheet2").Cells(i1, 1))

Worksheets("Sheet2").Cells(i1, 2) = cnt
Next i1
End Sub

この回答へのお礼

lotilyxoen様、ご回答ありがとうございました。
14分ぐらいかかっていた処理が33秒まで短縮されました。
こんなにも違いが出るとは正直驚きです。本当に勉強になりました。

お礼日時：2009/08/22 13:43

No.5 回答者： Wendy02 回答日時： 2009/08/22 11:35

こんにちは。

>Application.StatusBar = "件数処理実行中・・・(現在 " & cntRec & "件)"

こんなオプションはいらないのでは？
既に、フィルタオプション等で、一意のリストが出来ているのは、残りは、このようにすれば済むと思います。

Sub TestMacro1()
Dim sRng As String
　With Worksheets("Sheet1")
　　sRng = .Range("B2", .Cells(Rows.Count, 2).End(xlUp)).Address(, , xlR1C1, True)
　End With
　With Worksheets("Sheet2")
　　With .Range("A2", .Cells(Rows.Count, 1).End(xlUp)).Offset(, 1)
　　.FormulaLocal = "=CountIf(" & sRng & ",RC[-1])"
　　.Value = .Value
　　End With
　End With
End Sub

No.4 回答者： cistronezk 回答日時： 2009/08/22 07:46

＞Application.StatusBar = "件数処理実行中・・・(現在 " & cntRec & "件)"

この表示処理にも時間がかかります。処理の進捗度合いを知りたいだけなら、

If cntRec Mod 100 = 0 Then
Application.StatusBar = "件数処理実行中・・・(現在 " & cntRec & "件)"
End If

とかした方が、速くはなります。速度を考慮したら表示しないのが一番ですが。

この回答へのお礼

cistronezk様、ご回答ありがとうございます。
ご指摘いただいたところを直したところ、直す前と比べて2、3秒ほど短縮できました。
相談前は10分以上かかっていた処理だったため、ハングアップでないことを
使用者に認識させる目的で表示させておりましたが、皆様のご回答のおかげで
1分を切るようになったため、cistronezk様のご助言どおり、表示させない方向で
検討してみます。

お礼日時：2009/08/22 13:49

No.2 回答者： nag0720 回答日時： 2009/08/22 04:10

もしSheet1がB列でソートされているとしたら、下記のコードでかなり早くなります。

もちろんB列でソートされていないと思いますので、いったん別の列にコピーしその列だけでソートしてから実行すればコピー＆ソートの時間が増えるだけ済みます。（当然参照列は変わります）

なお、コピー＆ソートをマクロの中に組み込むこともできますので、必要ならそうしてください。


Sub Test()
Dim i As Integer
Dim dc1 As Integer
Dim dc2 As Integer
Dim S As String
Dim cnt As Integer
Dim cntRec As Integer
dc1 = Worksheets("Sheet1").Range("A65536").End(xlUp).Row
dc2 = Worksheets("Sheet2").Range("A65536").End(xlUp).Row

For i = 2 To dc2
　Worksheets("Sheet2").Cells(i, 2) = 0
Next i
cntRec = 0
i = 2
S = Worksheets("Sheet1").Cells(i, 2).Value
cnt = 1
Do
　i = i + 1
　If Worksheets("Sheet1").Cells(i, 2).Value <> S Or i > dc1 Then
　　If S <> "" Then
　　　Worksheets("Sheet2").Range("A2:A" & dc2).Find(What:=S).Offset(0, 1).Value = cnt
　　　cntRec = cntRec + 1
　　　Application.StatusBar = "件数処理実行中・・・(現在 " & cntRec & "件)"
　　End If
　　S = Worksheets("Sheet1").Cells(i, 2)
　　cnt = 0
　End If
　cnt = cnt + 1
Loop While i <= dc1
End Sub

この回答へのお礼

nag0720様、ご回答ありがとうございます。
14分ほどかかっていた処理が35秒まで短縮されました。
今回は他の方の方法で対応させていただきましたが、非常に勉強になりました。

お礼日時：2009/08/22 14:06

No.1 回答者： hige_082 回答日時： 2009/08/22 02:35

配列を使用する方法です

Sub test()
Dim dc1 As Variant
Dim dc2 As Variant
Dim i1 As Long, i2 As Long, cnt As Long, cntRec As Long
dc1 = Worksheets("Sheet1").Range("B2", Worksheets("Sheet1").Range("B65536").End(xlUp))
dc2 = Worksheets("Sheet2").Range("A2", Worksheets("Sheet2").Range("A65536").End(xlUp))
For i1 = 1 To UBound(dc2, 1)
cnt = 0
For i2 = 1 To UBound(dc1, 1)
If dc2(i1, 1) = dc1(i2, 1) Then
cnt = cnt + 1
End If
Next i2
Worksheets("Sheet2").Cells(i1 + 1, 2) = cnt
cntRec = cntRec + 1
Application.StatusBar = "件数処理実行中・・・(現在 " & cntRec & "件)"
Next i1
'Application.StatusBar = False
End Sub

参考まで

この回答へのお礼

hige_082様、ご回答ありがとうございます。
14分ぐらいかかっていた処理が55秒と素晴らしく短縮されました。
今回は別の方の方法で対処させていただきましたが、
本当に勉強になりました。

お礼日時：2009/08/22 13:39