エクセル VBA VBAを勉強するにあたり、いつもお世話になってます。 今回教えていただきたいのは、

エクセル VBA

VBAを勉強するにあたり、いつもお世話になってます。
今回教えていただきたいのは、複数項目が重複するセルの数を数える方法を教えてください。
A列 No.
B列 名前
C列 年齢
Ｄ列 カウントした数
で例えば、
A1 111
B1鈴木
C1 43
C1まで入力した際にマクロ実行しＤ1 1と表示。次に
A2 222
B2 田中
C2 39
実行
Ｄ2 1 Ｄ1はそのまま1
A3 111
B3 鈴木
C3 43
実行
Ｄ3 2 Ｄ1は1、Ｄ2は1のまま
というものです。わかりにくい説明ですが、ご教授いだきたいです。よろしくお願います。

No.1 回答者： fujillin 回答日時： 2019/09/12 10:56

こんにちは

A、B、C列の値全てが同じ場合に重複とカウントするということと解釈しました。

こんなのではいかがでしょうか？
Sub Sample()
Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp)).Offset(, 3).FormulaLocal = _
"=IF(A1="""","""",COUNTIFS(A$1:A1,A1,B$1:B1,B1,C$1:C1,C1))"
End Sub

この回答へのお礼

ご回答ありがとうございます。
FormulaLocal はじめてみたものなので、勉強します！

お礼日時：2019/09/12 14:42

No.2 回答者： tatsu99 回答日時： 2019/09/12 11:03

もし、３行目に

A3　１１１
B3　山本
C3　４３
となっていたら、D3はいくつをセットすればよいのですか。
又、
A3　１１１
B3　鈴木
C3　４２
の場合は、D3はどうなりますか。

この回答へのお礼

ご回答ありがとうございます。ご質問に、あった件ですが、
A3　１１１
B3　山本
C3　４３
となっていた場合、D3は1。
又、
A3　１１１
B3　鈴木
C3　４２
の場合も、D3は1といたいと思っております。よろしくお願います。

お礼日時：2019/09/12 11:55

No.3 ベストアンサー 回答者： tatsu99 回答日時： 2019/09/12 12:16

すでに回答はでてますが、もっとも素直な方法です。

Public Sub 重複カウント()
Dim maxrow As Long
Dim wrow As Long
Dim ctr As Long
maxrow = Cells(Rows.Count, 1).End(xlUp).Row
ctr = 0
For wrow = 1 To maxrow
If Cells(wrow, 1).Value = Cells(maxrow, 1).Value And _
Cells(wrow, 2).Value = Cells(maxrow, 2).Value And _
Cells(wrow, 3).Value = Cells(maxrow, 3).Value Then
ctr = ctr + 1
End If
Next
Cells(maxrow, 4).Value = ctr
End Sub

この回答へのお礼

ご回答ありがとうございます。確かに今の私にはわかりやすいものです！こちらを、元にもう少し自分でも勉強してみます！

お礼日時：2019/09/12 17:40

No.4 回答者： めぐみん_ 回答日時： 2019/09/12 15:25

既に回答は出ていますけど、その後質問者さん自身で目的の、

＞C1まで入力した際にマクロ実行しＤ1 1と表示

のイベントに作り替えられると言う事でしょうか？
その場合なら私のはお古なので検証不可能ですが、既出ている『COUNTIFS関数』で『先頭行から現在編集完了した行』までを複数条件でカウントすれば可能のように思います。
ただ、私には検証できません！けど。

若しくはマクロの実行条件として『Ｃ列への入力完了後』とは違ってましたかね？

この回答へのお礼

ありがとうございます。
実は、 AからCまでの各行毎に入力をマクロでしていて、その結果をＤ列に表示といったかたちにしたいと思っております。こちらで教えいただいたものを参考に一つのマクロを作成出来ればと考えてますので教えていただけると助かります。

お礼日時：2019/09/12 21:17

No.5 回答者： tom04 回答日時： 2019/09/12 17:59

こんにちは！

横からお邪魔します。
No.4さんも仰っているようにCOUNTIFS関数で対応できますが、
今回はVBAでの方法をご希望だというコトなので、一例です。
↓の画像のような配置（1行目は項目行）になっているという前提です。

Sub Sample1()
　Dim myDic As Object
　Dim i As Long, myStr As String
　　Set myDic = CreateObject("Scripting.Dictionary")
　　　For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
　　　　myStr = Cells(i, "A") & "_" & Cells(i, "B") & "_" & Cells(i, "C")
　　　　　If Not myDic.exists(myStr) Then
　　　　　　myDic.Add myStr, 1
　　　　　Else
　　　　　　myDic(myStr) = myDic(myStr) + 1
　　　　　End If
　　　　　Cells(i, "D") = myDic(myStr)
　　　Next i
　　　　Set myDic = Nothing
End Sub

こんな感じでも大丈夫だと思います。m(_ _)m

この回答へのお礼

ありがとうございます。
いろんな方法が、あるのですね！！こちらのコードも一つ一つ見て勉強させていただきます！ほんとうにありがとうございます！

お礼日時：2019/09/12 21:18