重複データのカウント

質問

VBAで進められなくて困っております。お知恵をお借りしたくよろしくお願い致します。
Excel2003使用

Ｃ列に入っている数字がどれくらいＣ列にあるか数えて、結果をＤ列に反映したいのですがうまくいかず困っております。
結果前
Ａ列　Ｂ列　Ｃ列
11　　105　　11105
11　　108　　11108
11　　108　　11108
12　　153　　12153
12　　161　　12161

結果イメージ
Ａ列　　Ｂ列　　Ｃ列　　Ｄ列
11　　105　　11105　　1
11　　108　　11108　　2
11　　108　　11108　　2
12　　153　　12153　　1
12　　161　　12161　　1

※作業を行っているシートは都合によりSheet2になっております。
　　1行目は項目が入っている為、データは2行目からです。

With Sheets("Sheet2")
.Range("C2",.Range("C"&.Rows.Count).End(xlUp)).Offset(,2).Formula=_
"=IF(OR(D2="""",COUNTIF(Sheet2!C:C,D2)=0,""""))"
End With

データの数量は5000件以上、場合によっては１万以上になります。
以上、宜しくお願いたします。

回答No.3

kagakusuki · ベストアンサー

C列のデータが数値であるのか、文字列であるのか、或いは、数値と文字列の両方が混ざり合っているのかには関係なしに、有効な方法です。

Sub QNo7846643その2()

Dim LR As Long
With Worksheets("Sheet2")
If Application.WorksheetFunction.Count(.Columns("C:C")) Then
LR = Application.WorksheetFunction.Match(9E+307, .Columns("C:C"))
Else
LR = 0
End If
If Application.WorksheetFunction.CountIf(.Columns("C:C"), "*?") Then
If LR < Application.WorksheetFunction.Match("*?", .Columns("C:C"), -1) Then
LR = Application.WorksheetFunction.Match("*?", .Columns("C:C"), -1)
End If
End If
If LR >= .Range("C2").Row Then
.Range("D2:D" & LR).Formula = "=IF(Index($C:$C,row())="""","""",CountIf(Sheet2!$C:$C,Index(Sheet2!$C:$C,Row())))"
End If
End With

End Sub

　或いは

Sub QNo7846643その3()

Dim LR As Long
Dim LRN As Long
Dim LRC As Long
With Worksheets("Sheet2")
If Application.WorksheetFunction.Count(.Columns("C:C")) > 0 Then
LRN = Application.WorksheetFunction.Match(9E+307, .Columns("C:C"))
Else
LRN = 0
End If
If Application.WorksheetFunction.CountIf(.Columns("C:C"), "*?") Then
LRC = Application.WorksheetFunction.Match("*?", .Columns("C:C"), -1)
End If
LR = Application.WorksheetFunction.Max(LRN, LRC)
If LR >= .Range("C2").Row Then
.Range("D2:D" & LR).Formula = "=IF(Index($C:$C,row())="""","""",CountIf(Sheet2!$C:$C,Index(Sheet2!$C:$C,Row())))"
End If
End With

End Sub

お礼

沢山の方法をご提示いただきありがとうございました！
ＮＯ．3と４と合わせて希望通りに動きました。
これから処理するデータの数が10万以上あるので大変助かりました！

回答No.5

kagakusuki

この様なやり方もあります。

Sub QNo7846643その4()

　With Worksheets("Sheet2").Range("D2:D" & Rows.Count)
　　.Value = .Offset(0, -1).Value
　 　.Replace what:="*", Replacement:="=COUNTIF(C:C,INDEX(C:C,ROW()))"
　　 .Value = .Value
　 End With

End Sub

回答No.4

kagakusuki

尚、D2以下のセルに関数を使わない、単なる数値データが入力されている状態としたい場合には、回答No.2及び回答No.3のVBAの中の

End With

の直上に次の様な1行を加えて下さい。

.Range("D2:D" & LR).Value = .Range("D2:D" & LR).Value

回答No.2

kagakusuki

C列が数値である場合にのみ有効な方法ですが、以下の様なものでは如何でしょうか。

Sub QNo7846643()

With Worksheets("Sheet2")
If Application.WorksheetFunction.Count(.Columns("C:C")) = 0 Then GoTo Sub1
Dim LR As Long
LR = Application.WorksheetFunction.Match(9E+307, .Columns("C:C"))
.Range("D2:D" & LR).Formula = "=IF(Index($C:$C,row())="""","""",CountIf(Sheet2!C:C,Index(Sheet2!C:C,Row())))"
Sub1:
End With

End Sub

回答No.1

goota33

C列の数をかぞえたいデータのあるシートをアクティブにして、
以下のコードを実行してみてください。
質問された通りの動作をするはずです。

Option Explicit

Public Sub test()
Dim i As Long
Dim lngLastRow As Long
Dim objMyDic As Object
Dim objBuff As Object

Set objMyDic = CreateObject("Scripting.Dictionary")
lngLastRow = Cells(Rows.Count, 3).End(xlUp).Row

For i = 1 To lngLastRow
If objMyDic.exists(Cells(i, 3).Value) = True Then
objMyDic.Item(Cells(i, 3).Value) = objMyDic.Item(Cells(i, 3).Value) + 1

Else
objMyDic.Add Cells(i, 3).Value, 1

End If

Next i

For i = 1 To lngLastRow
Cells(i, 4).Value = objMyDic.Item(Cells(i, 3).Value)

Next i

End Sub

お礼

ご提示ありがとうございました。
時間を計ってみたらとても速く動いて吃驚しました。
数字のみで同じような作業の時に活用させて頂こうとおもいます！