エクセルマクロ 重複データの最新日付を抽出する 2選

エクセルマクロで、重複データの最新日付を抽出するVBAコードをご紹介します。

このページのマクロコードは、コピペで使えます。
ぜひお試しください😉

重複データの最新日付を抽出

以下のExcelVBAを実行すると、重複データの最新日付を探してフラグを付けます。

Sub 重複データから最新だけフラグ付け()

Dim DicName, myKey As Variant
Dim i, j As Long
Dim Max, MaxRow, LastRow As Long
Dim Target As String

    '連想配列
    Set DicName = CreateObject("Scripting.Dictionary")

    '最終行
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row

    '2～最終行までループ
    For i = 2 To LastRow
        Target = Cells(i, 1)

        '重複しない 「商品名」 を連想配列へ
        If Not DicName.exists(Target) Then
            DicName.Add Target, Target
        End If
    Next i

    Application.ScreenUpdating = False

        '重複しない 「商品名」 をループ
        myKey = DicName.keys
        For i = LBound(myKey) To UBound(myKey)

            '「商品名」が2個以上だったら
            If WorksheetFunction.CountIf(Range(Cells(2, 1), Cells(LastRow, 2)), myKey(i)) > 1 Then

                Max = 0
                MaxRow = 0

                '2～最終行までループ
                For j = 2 To Cells(Rows.Count, 1).End(xlUp).Row

                    '最新の日付の行を [MaxRow] に格納
                    If Cells(j, 1) = myKey(i) Then
                        If Max < Cells(j, 2) Then
                            Max = Cells(j, 2)
                            MaxRow = j
                        End If
                    End If
                Next j

                'C列にフラグ「1」を入力
                Cells(MaxRow, 3) = 1
            End If
        Next i

    Application.ScreenUpdating = True

End Sub

マクロ実行後

A列「商品名」で重複しているデータの中で、
B列が最新日付のものに、「1」を入力します。

補足

「商品名」が重複していない場合、「1」は入力しません。

「商品名」が重複していて「日付」が同じ場合は、片方に「1」が付きます。

重複データの最新日付を抽出（別シート転記）

以下のExcelVBAを実行すると、重複データの最新日付を別のシートに転記します。

Sub 重複データから最新日付を別シート抽出()

Dim DicName, myKey As Variant
Dim i, j As Long
Dim Max, MaxRow, LastRow, Cnt As Long
Dim Target As String
Dim Sht1, Sht2 As Worksheet

    Set Sht1 = Sheets("Sheet1")
    Set Sht2 = Sheets("Sheet2")
    Cnt = 1
    Sht1.Select

    '連想配列
    Set DicName = CreateObject("Scripting.Dictionary")

    '最終行
    LastRow = Sht1.Cells(Rows.Count, 1).End(xlUp).Row

    '2～最終行までループ
    For i = 2 To LastRow
        Target = Sht1.Cells(i, 1)

        '重複しない 「商品名」 を連想配列へ
        If Not DicName.exists(Target) Then
            DicName.Add Target, Target
        End If
    Next i

    Application.ScreenUpdating = False

        '重複しない 「商品名」 をループ
        myKey = DicName.keys
        For i = LBound(myKey) To UBound(myKey)

            '「商品名」が2個以上だったら
            If WorksheetFunction.CountIf(Sht1.Range(Cells(2, 1), Cells(LastRow, 2)), myKey(i)) > 1 Then

                Max = 0
                MaxRow = 0

                '2～最終行までループ
                For j = 2 To LastRow

                    '最新の日付の行を [MaxRow] に格納
                    If Cells(j, 1) = myKey(i) Then
                        If Max < Sht1.Cells(j, 2) Then
                            Max = Sht1.Cells(j, 2)
                            MaxRow = j
                        End If
                    End If
                Next j

                'C列にフラグ「1」を入力
                Sht1.Range(Cells(MaxRow, 1), Cells(MaxRow, 2)).Copy Sht2.Cells(Cnt, 1)
                Cnt = Cnt + 1
            End If
        Next i

    Application.ScreenUpdating = True

End Sub

マクロ実行後

「Sheet1」のA列「商品名」で重複しているデータの中で、
B列が最新日付のものを、別シート（Sheet2）に転記します。

補足

「商品名」が重複していない場合は、転記対象外となります。

「商品名」が重複していて「日付」が同じ場合は、
片側を「Sheet2」に転記します。

 
この記事がお役に立ちますと幸いです。
 
・【エクセルマクロ】重複データを自動処理する使用例まとめ
 

【エクセルマクロ】重複データを自動操作：超便利１３選

...

kirinote.com

2022.06.04