EXCEL VBA で重複するデータを抜き出し、カウントしたい

こんばんは。

EXCEL VBAで重複するデータを抜き出し、カウントする方法をご教示ください。
（sheet1からsheet2へ）
sheet1

a　 b　　　　
NO 氏名
１　　田中
２　　鈴木
３　　松尾
１　　田中
４　　池田
５　　松尾
２　　鈴木
(sheet1にはこの他にもたくさんデータが入っています。2万行ぐらい（変動有）））


sheet2

NO 氏名　　回数
1　　　田中　　2
2 鈴木　　2
3 松尾 2
4 池田　　1
5 松尾 1

NO順で氏名出現回数をカウントしたい。（NOと氏名は連動）

dictionaryを使えば、いいと思うのですがうまくできません。
ご教示よろしくお願い致します。

No.4 ベストアンサー 回答者： tom04 回答日時： 2019/05/03 09:03

こんにちは！

一例です。
標準モジュールにしてください。

Sub Sample1()
　Dim myDic As Object
　Dim i As Long, lastRow As Long
　Dim myStr As String, wS As Worksheet
　Dim myKey, myItem, myR, myAry

　　Set myDic = CreateObject("Scripting.Dictionary")
　　Set wS = Worksheets("Sheet2")
　　　wS.Range("A:C").ClearContents
　　　　With Worksheets("Sheet1")
　　　　　wS.Range("A1:B1").Value = .Range("A1:B1").Value
　　　　　wS.Range("C1") = "回数"
　　　　　　lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
　　　　　　　myR = Range(.Cells(2, "A"), .Cells(lastRow, "B"))
　　　　　　　　For i = 1 To UBound(myR, 1)
　　　　　　　　　myStr = myR(i, 1) & "_" & myR(i, 2)
　　　　　　　　　　If Not myDic.exists(myStr) Then
　　　　　　　　　　　myDic.Add myStr, 1
　　　　　　　　　　Else
　　　　　　　　　　　myDic(myStr) = myDic(myStr) + 1
　　　　　　　　　　End If
　　　　　　　　Next i
　　　　End With
　　　　　myKey = myDic.keys
　　　　　myItem = myDic.items
　　　　　　myR = Range(wS.Cells(2, "A"), wS.Cells(UBound(myKey) + 2, "C"))
　　　　　　　For i = 0 To UBound(myKey)
　　　　　　　　myAry = Split(myKey(i), "_")
　　　　　　　　　myR(i + 1, 1) = myAry(0)
　　　　　　　　　myR(i + 1, 2) = myAry(1)
　　　　　　　　　myR(i + 1, 3) = myItem(i)
　　　　　　　Next i
　　　　　　Range(wS.Cells(2, "A"), wS.Cells(UBound(myKey) + 2, "C")) = myR
　　　　　　　wS.Range("A1").CurrentRegion.Sort key1:=wS.Range("A1"), order1:=xlAscending, Header:=xlYes
　　　　　　　Set myDic = Nothing
　　　　　　　wS.Activate
　　　　　　MsgBox "完了"
End Sub

こんな感じではどうでしょうか？m(_ _)m

この回答へのお礼

ご回答ありがとうございました。
思い通りできました。
感謝致します。

お礼日時：2019/05/03 21:20

No.7 回答者： めぐみん_ 回答日時： 2019/05/03 19:38

うちのは古いので参考にならないかもですが。

Sub megu()
Dim myLst As Object
Dim r As Range, i As Long, v

Set myLst = CreateObject("System.Collections.SortedList")

With Worksheets("Sheet1")
For Each r In .Range("A2", .Cells(Rows.Count, 1).End(xlUp))
If Not myLst.Contains(r.Value) Then myLst.Add r.Value, Array(r.Value, r.Offset(, 1).Value, 0)
v = myLst.GetByIndex(myLst.IndexOfKey(r.Value))
v(2) = v(2) + 1
myLst.Item(r.Value) = v
Next
End With

With Worksheets("Sheet2")
.Cells.ClearContents
.Range("A1:C1").Value = Array("NO", "名前", "回数")
For i = 0 To myLst.Count - 1
.Range("A2").Offset(i).Resize(, 3).Value = myLst.GetByIndex(i)
Next
End With

Set myLst = Nothing
End Sub

この回答へのお礼

ご回答ありがとうございました。
勉強になりました。

お礼日時：2019/05/03 21:18

No.6 回答者： 30246kiku 回答日時： 2019/05/03 17:20

以下でどうなりますか

元データを３列分読み込んで、上に詰め直しながら３列目に出現数を･･･
結果は、詰め直した分を書き出すだけ


Option Explicit

Public Sub Samp1()
　　Dim dic As Object
　　Dim vA As Variant
　　Dim sS As String
　　Dim i As Long, k As Long, n As Long

　　Set dic = CreateObject("Scripting.Dictionary")

　　With Worksheets("Sheet1")
　　　　With .Range("A1", .Cells(Rows.Count, "A").End(xlUp))
　　　　　　vA = .Resize(, 3).Value
　　　　End With
　　End With

　　n = 1
　　vA(n, 3) = "回数"
　　For i = 2 To UBound(vA)
　　　　sS = vA(i, 1) & vbTab & vA(i, 2)
　　　　k = dic(sS)
　　　　If (k = 0) Then
　　　　　　n = n + 1
　　　　　　dic(sS) = n
　　　　　　vA(n, 1) = vA(i, 1)
　　　　　　vA(n, 2) = vA(i, 2)
　　　　　　vA(n, 3) = 1
　　　　Else
　　　　　　vA(k, 3) = vA(k, 3) + 1
　　　　End If
　　Next

　　Application.ScreenUpdating = False
　　With Worksheets("Sheet2")
　　　　With .Range("A1").Resize(n, 3)
　　　　　　.EntireColumn.ClearContents
　　　　　　.Value = vA
　　　　　　.Sort .Cells(1), xlAscending, Header:=xlYes
　　　　End With
　　End With
　　Application.ScreenUpdating = True

　　Set dic = Nothing
End Sub

この回答へのお礼

ご回答ありがとうございました。
勉強になりました。

お礼日時：2019/05/03 21:19

No.5 回答者： komugi3333 回答日時： 2019/05/03 14:18

行の重複をカウントするだけでしたら、基本的にはVBAを使わなくてもピボットテーブルでもできます。

Sheet2に、「Sheet1をソースにしたピボット」を作り、以下のようなフィールド構成にします。

・行ラベル：「NO」「氏名」
・値：氏名（計算方法は「個数」）


バカみたいなダサいプログラムですみませんが、そのようなピボットを作成するサンプルプログラムを、いちおう、ご紹介いたします。
（※注！！！ データがどうなってしまうか分かりませんので、必ずバックアップをいくつか作ってから、そのバックアップのほうでテストしてみてください。また、Sheet1の1行目がすべて列名となっていて、空白行や空白列が無いことが前提です。A1セルに表の名前などが入っていてその右が空白セルドだと誤作動します。）

・以下のプログラムをVBEの標準モジュールにコピペしたのち、
・ピボットを作りたい空白のシートをアクティブにしてから、
・「PivotMake02()」のほうだけを実行してみてください。


Sheet1のデータの列が増えても行が増えても可変の、再設定は何もしなくていいピボットが、現在アクティブなシートに作成されます（・・・るはずです・・・^^。動かなかったら本当にごめんなさい。なお、行と列を可変にしてピボットを作る処理は関数化？というんでしょうか？してあります。）

＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

Sub PivotMake02()

　　Dim o_Pvt01 As PivotTable

　　
　　'現在のシートにピボットテーブルの作成
　　Call Off2010MakePvt0022("Sheet1", "testTblRng02", ActiveSheet.Name, "A3", "test01Pivot")
　　
　　
　　'できたピボットを選択
　　Set o_Pvt01 = ActiveSheet.PivotTables("test01Pivot")
　　
　　
　　'値を"氏名"の個数で。（勝手に個数になるみたい）
　　o_Pvt01.AddDataField o_Pvt01.PivotFields("氏名")
　　
　　'行ラベルを"NO"と"氏名"に設定。
　　o_Pvt01.AddFields RowFields:=Array("NO", "氏名")
　　
　　'小計フィールドの非表示設定
　　o_Pvt01.PivotFields("NO").Subtotals(1) = False
　　
　　
End Sub


'##################################################################################
'Office2010形式で、ピボットソースの列と行の増加を可変にして、
'古い形式のピボットを作る関数
'
'「s_SrcTblShtNm」：ピボットのソースにしたい表（テーブル）が在るシートの名前
'「s_AddSrcRngNm」：その表を、名前定義機能で名前をつけるときの、そのセル範囲の名前
'「s_PvtTgtShtNm01」：ピボットを作成したいシートの名前
'「s_PvtTgtCelAdrr01」：そのシートの、ピボットを出力したい起点となるセルのアドレス。
' 　　（ピボットの上の2行分はページ切り替え用の領域になるので2行分はあけておく。
'　　　　なのでこの値は「A3」が一般的。でも「D5」でも「F10」でもどこでもOKです。）
'「s_PvtTbleNm01」：ピボットテーブルそのものに付けたい名前
'
'##################################################################################

Function Off2010MakePvt0022(s_SrcTblShtNm As String, _
　　　　　　　　　　　　　　s_AddSrcRngNm As String, _
　　　　　　　　　　　　　　s_PvtTgtShtNm01 As String, _
　　　　　　　　　　　　　　s_PvtTgtCelAdrr01 As String, _
　　　　　　　　　　　　　　s_PvtTbleNm01 As String)

　　Dim ObjCache　　　　　　As PivotCache
　　Dim ObjTable　　　　　　As PivotTable
　　Dim StrActvShtName　　　As String
　　Dim CurrentShtNm01　　　As String
　　Dim PvtOutputShtName01　As String
　　
　　CurrentShtNm01 = ActiveSheet.Name
　　
　　
　　'現在のシート（アクティブなシート）の行と列が増えても
　　'ピボットの再設定をしなくても済むようにする処置
　　'「=OFFSET($A$1,0,0,COUNTA($A:$A),COUNTA($1:$1))」にて
　　'名前の定義の操作をして、ソースとなる表に「pvtsrc01」という名前を付けます。
'　　ActiveWorkbook.Names.Add Name:="pvtsrc01", RefersToR1C1:= _
'　　　　"=OFFSET(データセット1!R1C1,0,0,COUNTA(データセット1!C1),COUNTA(データセット1!R1))"
'　　StrActvShtName = ActiveSheet.Name
　　ActiveWorkbook.Names.Add Name:=s_AddSrcRngNm, RefersToR1C1:= _
　　　　"=OFFSET(" & s_SrcTblShtNm & "!R1C1,0,0,COUNTA(" & s_SrcTblShtNm & "!C1),COUNTA(" & s_SrcTblShtNm & "!R1))"
　　ActiveWorkbook.Names(s_AddSrcRngNm).Comment = ""


　　'ピボットキャッシュの作成（名前の定義をした「pvtsrc01」をソースにして。）
'　　Set ObjCache = ActiveWorkbook.PivotCaches.Create _
'　　(SourceType:=xlDatabase, SourceData:=Range("A1").CurrentRegion)
　　Set ObjCache = ActiveWorkbook.PivotCaches.Create _
　　(SourceType:=xlDatabase, SourceData:=s_AddSrcRngNm)
　　　　
　　　　
　　　　
　　'ピボット作りたいシートの指定。（既存か新規かの設定）
　　If CurrentShtNm01 = s_PvtTgtShtNm01 Then
　　
　　　　'既存のシートへ作りたいなら、そのままそこを指定。
　　　　PvtOutputShtName01 = CurrentShtNm01
　　
　　Else
　　　　'新しいシートへ作りたいなら、新規シートを作ってからそこを指定。
　　　　Worksheets.Add　　　　　　　　　 '新しいシートの作成
　　　　ActiveSheet.Name = s_PvtTgtShtNm01　'そのシートの名前を「Pvt01」にする
　　　　PvtOutputShtName01 = ActiveSheet.Name
　　
　　End If
　　

　　
'　　'新しいシートへの空のピボットテーブルの作成
'　　Set ObjTable = ObjCache.CreatePivotTable _
'　　(TableDestination:=Worksheets("Pvt01").Range("A3"), TableName:="test01Pivot")

　　'新しいシートへの空のピボットテーブルの作成
　　Set ObjTable = ObjCache.CreatePivotTable _
　　(TableDestination:=Worksheets(PvtOutputShtName01).Range(s_PvtTgtCelAdrr01), TableName:=s_PvtTbleNm01)
　　

　　'古いタイプのピボットの表示・操作性への切り替え
　　'（古いタイプでなくても良ければここは５行全部をコメントアウトします）
　　Worksheets(s_PvtTgtShtNm01).Range(s_PvtTgtCelAdrr01).Select　　　　　'新しく作ったピボットの任意のセルを選択
　　With ActiveSheet.PivotTables(s_PvtTbleNm01)
　　　　.HasAutoFormat = False
　　　　.InGridDropZones = True
　　　　.RowAxisLayout xlTabularRow
　　End With
　　
　　
End Function

この回答へのお礼

ご回答ありがとうございました。

お礼日時：2019/05/03 21:18

No.3 回答者： めぐみん_ 回答日時： 2019/05/03 09:02

シート２の表示順についてはシート１の上から見つけた順ですか？

それとも『回数』が降順・『Ｎｏ』が昇順ですか？

No.2 回答者： tatsu99 回答日時： 2019/05/02 23:01

補足要求です。

１．1行目は見出し行ですか。それとも、データ行ですか。
２．同じNOで、異なる氏名が発生することはないですか。
提示例では、
NO＝１　氏名＝田中　となった行が２つありますが、
上記のほかに
NO＝１　氏名＝山田　となるような行がありえますか。
もし、あったなら、NO=１ 氏名＝山田の行は無視してよいのですか？

この回答へのお礼

tatsu99さん、ご返事ありがとうございましす。
１．1行目は見出し行です。
２．NOと氏名は連動しています。NO1は田中しかありません。

お礼日時：2019/05/03 06:09

No.1 回答者： GOMΛFU 回答日時： 2019/05/02 22:08

sheet2 「3 松尾 2」 の仕様はなんでしょう？

この回答へのお礼

GOMAFUさん、ご返信ありがとうございます。
すみません。書き間違えです。
名前はフルネームで入っていますので、同姓同名はいません。
NOと名前は連動しています。
（３　松尾勇　　５松尾隆　みたいな感じです）

お礼日時：2019/05/03 06:12