重複リストを抽出して、ある項目は最新お日付の方のデータを反映、あるデータは合算して1つのデータにしたいVBA

前提・実現したいこと

ある会員データを集計するにあたり、重複している会員を見つけ、重複者を1つのデータに作り替えて元のリストに戻したいと考えています。
１つのVBAで完結まで想像できなかったので以下の作業で切り分けようと考えております。

このような会員リストがあります。

１）「個人番号」をキーに重複者を見つけ別シートに重複者リストを作成します。

２）重複者を1つのデータに作り替えるのですが
「会員番号」「住所」「会員取得年月日」「身長」「体重」は「会員取得年月日」の最新日の方のデータを採用
「プラン面談」「食事相談」は丸がついているものを合算
「オプション１料金」「オプション２料金」はそれぞれ合算
というルールで1つのデータに作り替えます。

３）1つのデータに作り替えたら元のリストに戻す

このようなVBAを作りたいと考えています。

発生している問題・エラーメッセージ

エラーメッセージ

該当のソースコード

Sub リスト取得()
    Dim i As Long
    Dim j As Long
    Dim lastrow As Long
    lastrow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
    Worksheets("Sheet2").Cells.Clear
    Worksheets("Sheet2").Cells(1, 1) = "個人番号"
    Worksheets("Sheet2").Cells(1, 2) = "会員番号"
    Worksheets("Sheet2").Cells(1, 3) = "氏名"
    Worksheets("Sheet2").Cells(1, 4) = "性別"
    Worksheets("Sheet2").Cells(1, 5) = "年齢"
    Worksheets("Sheet2").Cells(1, 6) = "生年月日"
    Worksheets("Sheet2").Cells(1, 7) = "住所"
    Worksheets("Sheet2").Cells(1, 8) = "会員取得年月日"
    Worksheets("Sheet2").Cells(1, 9) = "会員喪失年月日"
    Worksheets("Sheet2").Cells(1, 10) = "身長"
    Worksheets("Sheet2").Cells(1, 11) = "体重"
    Worksheets("Sheet2").Cells(1, 12) = "プラン相談"
    Worksheets("Sheet2").Cells(1, 13) = "食事相談"
    Worksheets("Sheet2").Cells(1, 14) = "オプション１利用料"
    Worksheets("Sheet2").Cells(1, 15) = "オプション２利用料"

    For i = 4 To lastrow
        Worksheets("Sheet2").Cells(i - 2, 1) = Worksheets("Sheet1").Cells(i, 1)
        Worksheets("Sheet2").Cells(i - 2, 2) = Worksheets("Sheet1").Cells(i, 2)
        Worksheets("Sheet2").Cells(i - 2, 3) = Worksheets("Sheet1").Cells(i, 3)
        Worksheets("Sheet2").Cells(i - 2, 4) = Worksheets("Sheet1").Cells(i, 4)
        Worksheets("Sheet2").Cells(i - 2, 5) = Worksheets("Sheet1").Cells(i, 5)
        Worksheets("Sheet2").Cells(i - 2, 6) = Worksheets("Sheet1").Cells(i, 6)
        Worksheets("Sheet2").Cells(i - 2, 7) = Worksheets("Sheet1").Cells(i, 7)
        Worksheets("Sheet2").Cells(i - 2, 8) = Worksheets("Sheet1").Cells(i, 8)
        Worksheets("Sheet2").Cells(i - 2, 9) = Worksheets("Sheet1").Cells(i, 9)
        Worksheets("Sheet2").Cells(i - 2, 10) = Worksheets("Sheet1").Cells(i, 10)
        Worksheets("Sheet2").Cells(i - 2, 11) = Worksheets("Sheet1").Cells(i, 11)
        Worksheets("Sheet2").Cells(i - 2, 12) = Worksheets("Sheet1").Cells(i, 12)
        Worksheets("Sheet2").Cells(i - 2, 13) = Worksheets("Sheet1").Cells(i, 13)
        Worksheets("Sheet2").Cells(i - 2, 14) = Worksheets("Sheet1").Cells(i, 14)
        Worksheets("Sheet2").Cells(i - 2, 15) = Worksheets("Sheet1").Cells(i, 15)

Next
    Worksheets("Sheet2").Activate
    Range(Cells(2, 1), Cells(i - 3, 16)).Select
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Cells(2, 1), SortOn _
        :=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Cells(2, 2), SortOn _
        :=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Cells(2, 3), SortOn _
        :=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Cells(2, 4), SortOn _
        :=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Cells(2, 5), SortOn _
        :=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Cells(2, 6), SortOn _
        :=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Cells(2, 7), SortOn _
        :=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Cells(2, 8), SortOn _
        :=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Cells(2, 9), SortOn _
        :=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Cells(2, 10), SortOn _
        :=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Cells(2, 11), SortOn _
        :=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Cells(2, 12), SortOn _
        :=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Cells(2, 13), SortOn _
        :=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Cells(2, 14), SortOn _
        :=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Cells(2, 15), SortOn _
        :=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

    With ActiveWorkbook.Worksheets("Sheet2").Sort
'並べ替える範囲を指定
        .SetRange Range(Cells(2, 1), Cells(i - 3, 16))
'1行目がタイトル行かどうか
        .Header = xlNo
'大文字と小文字を区別するかどうか
        .MatchCase = False
'並べ替えの方向(行/列)を指定
        .Orientation = xlTopToBottom
'ふりがなを使うかどうか
        .SortMethod = xlPinYin
'並べ替えを実行
        .Apply
    End With
    Call 最新の取り出し

End Sub

Sub 最新の取り出し()
    Dim i As Long
    Dim j As Long
    Dim lastrow As Long
    Dim kei As Long
    Dim kei1 As Double
    Dim kei2 As Double
    Dim maru1 As String
    Dim maru2 As String
    
    lastrow = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
    For i = 2 To lastrow
        Worksheets("Sheet2").Cells(i, 16) = 1
    Next
    Worksheets("Sheet3").Cells(1, 1) = "個人番号"
    Worksheets("Sheet3").Cells(1, 2) = "会員番号"
    Worksheets("Sheet3").Cells(1, 3) = "氏名"
    Worksheets("Sheet3").Cells(1, 4) = "性別"
    Worksheets("Sheet3").Cells(1, 5) = "年齢"
    Worksheets("Sheet3").Cells(1, 6) = "生年月日"
    Worksheets("Sheet3").Cells(1, 7) = "住所"
    Worksheets("Sheet3").Cells(1, 8) = "会員取得年月日"
    Worksheets("Sheet3").Cells(1, 9) = "会員喪失年月日"
    Worksheets("Sheet3").Cells(1, 10) = "身長"
    Worksheets("Sheet3").Cells(1, 11) = "体重"
    Worksheets("Sheet3").Cells(1, 12) = "プラン相談"
    Worksheets("Sheet3").Cells(1, 13) = "食事相談"
    Worksheets("Sheet3").Cells(1, 14) = "オプション１利用料"
    Worksheets("Sheet3").Cells(1, 15) = "オプション２利用料"
    
    Worksheets("Sheet3").Cells(1, 16) = "件数"

    j = 2
    kei = 0
    maru1 = ""
    maru2 = ""
    kei1 = 0
    kei2 = 0
    
    
    For i = 2 To lastrow
        kei = kei + Worksheets("Sheet2").Cells(i, 16)
        kei1 = kei1 + Worksheets("Sheet2").Cells(i, 14)
        kei2 = kei2 + Worksheets("Sheet2").Cells(i, 15)
        
        If Worksheets("Sheet2").Cells(i, 12) = "○" Then
            maru1 = "○"
        End If
        If Worksheets("Sheet2").Cells(i, 13) = "○" Then
            maru2 = "○"
        End If

        
        If Worksheets("Sheet2").Cells(i, 1) <> Worksheets("Sheet2").Cells(i + 1, 1) Then
            Worksheets("Sheet3").Cells(j, 1) = Worksheets("Sheet2").Cells(i, 1)
            Worksheets("Sheet3").Cells(j, 2) = Worksheets("Sheet2").Cells(i, 2)
            Worksheets("Sheet3").Cells(j, 3) = Worksheets("Sheet2").Cells(i, 3)
            Worksheets("Sheet3").Cells(j, 4) = Worksheets("Sheet2").Cells(i, 4)
            Worksheets("Sheet3").Cells(j, 5) = Worksheets("Sheet2").Cells(i, 5)
            Worksheets("Sheet3").Cells(j, 6) = Worksheets("Sheet2").Cells(i, 6)
            Worksheets("Sheet3").Cells(j, 7) = Worksheets("Sheet2").Cells(i, 7)
            Worksheets("Sheet3").Cells(j, 8) = Worksheets("Sheet2").Cells(i, 8)
            Worksheets("Sheet3").Cells(j, 9) = Worksheets("Sheet2").Cells(i, 9)
            Worksheets("Sheet3").Cells(j, 10) = Worksheets("Sheet2").Cells(i, 10)
            Worksheets("Sheet3").Cells(j, 11) = Worksheets("Sheet2").Cells(i, 11)
            Worksheets("Sheet3").Cells(j, 12) = maru1
            Worksheets("Sheet3").Cells(j, 13) = maru2
            Worksheets("Sheet3").Cells(j, 14) = kei1
            Worksheets("Sheet3").Cells(j, 15) = kei2
            
            Worksheets("Sheet3").Cells(j, 16) = kei
            j = j + 1
            kei = 0
            kei1 = 0
            kei2 = 0
            maru1 = ""
            maru2 = ""

        End If
    Next
    
   
    Worksheets("Sheet3").Select

End Sub

試したこと

ここに問題に対して試したことを記載してください。

補足情報（FW/ツールのバージョンなど）

いろんなところを参考にVBA書いてみたのですがうまくいきません。
またデータが多くなるとこのコードではすごく重くなります。
ご教授いただきたくよろしくお願いいたします。

radames1000

2021/01/12 06:29 編集

途中まででもご自身で書かれたコードを提示してください。と書いた瞬間に修正されたのですね。失礼しました。

退会済みユーザー

2021/01/12 06:42

どの箇所が重くなるのかは把握されていますか？

marino_2021

2021/01/12 06:49

For i =　~　NEXT の繰り返しの部分でしょうか。

退会済みユーザー

2021/01/12 07:14

もう少し具体的に、どの For が重くなるのかを把握する必要がありますね。ぱっと見、並べ替えが重くなりそうな気はしますが。

tatsu99

2021/01/12 08:52

動作環境はWindowsでしょうか。 WindowsのExcelならDictionaryが使えます。 Dictionaryを使用すれば、かなり高速になります。（MacではDictionaryは使用できません）

meg_

2021/01/12 12:42

> いろんなところを参考にVBA書いてみたのですがうまくいきません。 > またデータが多くなるとこのコードではすごく重くなります。何がどううまくいかないのでしょうか？動作が重いことが課題ですか？他にも何かありますか？

marino_2021

2021/01/12 23:56

一番の課題は目的通りVBAで動かせないところです。（重複チェック→2つの法則で1つのデータにする→元のリストに戻す）。まずは目的達成のためにはどのようなVBAを構築したらいいのか、そして実際のデータが列150列以上、件数15000件前後のデータをスムーズに稼働させるためのテクニックまで解決できればと思っています。

tatsu99

2021/01/13 00:01

>実際のデータが列150列以上ということは、O列より右側に、ほかにデータがあるのですか。あるとすれば、どのような、ルールで１つにまとめるのですか？あと、動作環境はwindowsでしょうか。

marino_2021

2021/01/13 00:08

動作環境はwindowsです。今回最低でもVBAで行いたいのは１）重複チェック２）重複者をルールにのっとり1つのデータにする３）実現できるなら元のリストに収めるです。３）は実現しなくても最悪は条件付き書式で重複者をピックアップして削除の後VBAで作成した新しいデータを加えるという方法も考えています。重複者だけ抜き取って作り替える、そして戻すというのがどうしてもわからなかったので、試しに全部データで一括で行おうと今回のVBAを書いてみたのですが思った通りに出来なくて質問に上げさせていただいた次第です。

行動規範の内容に同意します

回答1件

ベストアンサー

Dictionaryを使用した例です。
データ件数が２万行程度でも、１０以内で終わりました。
Sheet1のデータを重複データを削除してSheet3に出力します。（処理するのはA列からO列まで）
Sheet2は使用しません。

VBA
1Public Sub 重複リスト統合()
2    Dim sh1 As Worksheet
3    Dim sh3 As Worksheet
4    Dim maxrow As Long  'Sheet1最大行
5    Dim wrow As Long    '作業行番号
6    Dim row3 As Long    'Sheet3行番号
7    Dim row1 As Long    'Sheet1行番号
8    Dim dicT As Object  'Dictionary キー：個人番号 値：sheet1の行番号のリスト
9    Dim key As Variant  'Dictionaryのキー
10    Dim Arrlist As Object   'Array List
11    Dim kai As Variant  '会員取得年月日
12    Dim i As Long
13    Dim kei1 As Variant 'オプション利用１合計
14    Dim kei2 As Variant 'オプション利用２合計
15    Dim maru1 As String 'プラン相談○
16    Dim maru2 As String '食事相談○
17    Application.ScreenUpdating = False
18    Set sh1 = Worksheets("Sheet1")
19    Set sh3 = Worksheets("Sheet3")
20    maxrow = sh1.Cells(Rows.count, "A").End(xlUp).Row 'sheet1 最終行を求める
21    Set dicT = CreateObject("Scripting.Dictionary") ' 連想配列の定義
22    'Sheet1を最終行まで処理
23    For wrow = 4 To maxrow
24        key = sh1.Cells(wrow, "B").value    '個人番号
25        If dicT.exists(key) = False Then
26            '個人番号未登録時、個人番号をDictionaryに登録
27            Set Arrlist = CreateObject("System.Collections.ArrayList")     '.NET Frameworkへの参照
28            dicT.Add key, Arrlist
29        End If
30        dicT(key).Add wrow                  '行番号を追加
31    Next
32    sh3.Cells.ClearContents
33    '見出しの設定
34    sh3.Range("A1:O1").value = sh1.Range("A3:O3").value
35    row3 = 2
36    'Dictionaryの全てのキー（部署）を処理
37    For Each key In dicT
38        row1 = dicT(key)(0)
39        If dicT(key).count = 1 Then
40            '重複なしなら、そのままコピー
41            sh3.Range("A" & row3 & ":O" & row3).value = sh1.Range("A" & row1 & ":O" & row1).value
42        Else
43            kai = sh1.Cells(row1, "H").value    '会員取得年月日
44            kei1 = Empty
45            kei2 = Empty
46            maru1 = ""
47            maru2 = ""
48            'ArrayList中の行番号をを全て処理
49            For i = 0 To dicT(key).count - 1
50                '会員取得年月日の最新の行を取得
51                wrow = dicT(key)(i)
52                If sh1.Cells(wrow, "H").value > kai Then
53                    kai = sh1.Cells(wrow, "H").value
54                    row1 = wrow
55                End If
56                'プラン面談
57                If sh1.Cells(wrow, "L").value = "○" Then
58                    maru1 = "○"
59                End If
60                '食事面談
61                If sh1.Cells(wrow, "M").value = "○" Then
62                    maru2 = "○"
63                End If
64                If sh1.Cells(wrow, "N").value <> "" Then
65                    kei1 = kei1 + sh1.Cells(wrow, "N").value    'オプション１
66                End If
67                If sh1.Cells(wrow, "O").value <> "" Then
68                    kei2 = kei2 + sh1.Cells(wrow, "O").value    'オプション２
69                End If
70            Next
71            'A～K列までコピー
72            sh3.Range("A" & row3 & ":K" & row3).value = sh1.Range("A" & row1 & ":K" & row1).value
73            'プラン面談～オプション2
74            sh3.Cells(row3, "L").value = maru1
75            sh3.Cells(row3, "M").value = maru2
76            sh3.Cells(row3, "N").value = kei1
77            sh3.Cells(row3, "O").value = kei2
78        End If
79        row3 = row3 + 1
80    Next
81    Application.ScreenUpdating = True
82    MsgBox ("完了")
83End Sub