こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

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

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

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

    ↓↓↓
(2)  A    B
| 出身 | 人数 |
├────┼────┤
| 岩手 |  1 |
| 秋田 |  2 |
| 沖縄 |  2 |
| 島根 |  1 |
| 岐阜 |  1 |
| 愛知 |  1 |
| 長野 |  1 |

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

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)のような表を作成するのに、もっと処理時間が短くなるような
書き方はありますでしょうか?よろしくお願いいたします。

投稿日時 - 2009-08-22 01:27:08

QNo.5226644

すぐに回答ほしいです

質問者が選んだベストアンサー

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

投稿日時 - 2009-08-22 04:15:30

お礼

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

投稿日時 - 2009-08-22 13:43:39

このQ&Aは役に立ちましたか?

1人が「このQ&Aが役に立った」と投票しています

回答(5)

ANo.5

こんにちは。

>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

投稿日時 - 2009-08-22 11:35:12

ANo.4

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

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

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

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

投稿日時 - 2009-08-22 07:46:09

お礼

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

投稿日時 - 2009-08-22 13:49:56

ANo.2

もし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

投稿日時 - 2009-08-22 04:10:54

お礼

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

投稿日時 - 2009-08-22 14:06:16

ANo.1

配列を使用する方法です

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

参考まで

投稿日時 - 2009-08-22 02:35:02

お礼

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

投稿日時 - 2009-08-22 13:39:36

あなたにオススメの質問