teratail
回答率
85.46%
質問するログイン新規登録

質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう！

新規登録して質問してみよう
ただいま回答率
85.46%
トップVBAに関する質問
VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

Q&A

解決済

1回答

2616閲覧

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

marino_2021
marino_2021

総合スコア1

VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

0グッド

1クリップ

投稿2021/01/12 06:23

編集2021/01/12 06:29

0

1

前提・実現したいこと

ある会員データを集計するにあたり、重複している会員を見つけ、重複者を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書いてみたのですがうまくいきません。
またデータが多くなるとこのコードではすごく重くなります。
ご教授いただきたくよろしくお願いいたします。

気になる質問をクリップする

クリップした質問は、後からいつでもMYページで確認できます。

またクリップした質問に回答があった際、通知やメールを受け取ることができます。

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

radames1000
radames1000

2021/01/12 06:29 編集

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

退会済みユーザー

2021/01/12 06:42

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

2021/01/12 06:49

For i =　~　NEXT の繰り返しの部分でしょうか。
退会済みユーザー

退会済みユーザー

2021/01/12 07:14

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

2021/01/12 08:52

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

2021/01/12 12:42

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

2021/01/12 23:56

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

2021/01/13 00:01

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

2021/01/13 00:08

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

回答1件

0

ベストアンサー

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

投稿2021/01/13 00:56

tatsu99
tatsu99

総合スコア5470

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

marino_2021
marino_2021

2021/01/13 01:08

すごく早い処理で驚いたとともに感動しました。 元データに反映させてみます。 ありがとうございました。
guest

あなたの回答

tips

太字

斜体

打ち消し線

見出し

引用テキストの挿入

コードの挿入

リンクの挿入

リストの挿入

番号リストの挿入

表の挿入

水平線の挿入

プレビュー

質問の解決につながる回答をしましょう。 サンプルコードなど、より具体的な説明があると質問者の理解の助けになります。 また、読む側のことを考えた、分かりやすい文章を心がけましょう。

15分調べてもわからないことは
teratailで質問しよう！

ただいまの回答率
85.46%

質問をまとめることで
思考を整理して素早く解決

テンプレート機能で
簡単に質問をまとめる

質問する

関連した質問

トップVBAに関する質問

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