【エクセルマクロ】重複データの最新日付を抽出する:コピペで使えるコード

VBA-重複データの最新日付を抽出-アイキャッチ ExcelVBA

エクセルマクロで、重複データの最新日付を抽出する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」が付きます。


 

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

以下の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」に転記します。


 
この記事がお役に立ちますと幸いです。
 

【エクセルマクロ】重複データを自動操作:超便利13選
...

 

「たった1秒で仕事が片づくExcel自動化の教科書【増強完全版】」
「5時間かかる作業が3時間でできます」ではなく「1秒で終わらせます」へ
毎日の業務を瞬時に終わらせるしくみを解説