VBA 重複データの削除方法

質問

いつもお世話になっております。

VBAを学習中の初心者です。

重複するデータの行を削除を行いたいのですが、ご指導をよろしくお願いします。

添付ファイルの左側のようなデータを作成しました。
作成したいデータは右側です。

同一日ごとに項目1,2,3が全く一緒になる行を削除したい。以上です。

なるべく理解しやすいコードでご指導いただけると助かります。

よろしくお願いいたします。

回答No.2

tom04 · ベストアンサー

こんばんは！
すでに回答は出ていますが・・・
元データがSheet1にあり、Sheet2に表示するようにしてみました。
標準モジュールです。

Sub Sample1()
Dim lastRow As Long
Application.ScreenUpdating = False
With Worksheets("Sheet1")
lastRow = .Cells(Rows.Count, "B").End(xlUp).Row
.Range("A:B").Insert
Range(.Cells(2, "A"), .Cells(lastRow, "A")).Formula = "=IF(C2="""",A1,C2)"
With Range(.Cells(2, "B"), .Cells(lastRow, "B"))
.Formula = "=A2&""_""&E2&""_""&MOD(ROW(),3)"
.Value = .Value
End With
.Range("B:B").AdvancedFilter Action:=xlFilterInPlace, unique:=True
Range(.Cells(1, "C"), .Cells(lastRow, "E")).SpecialCells(xlCellTypeVisible).Copy Worksheets("Sheet2").Range("A1")
.ShowAllData
.Range("A:B").Delete
End With
Application.ScreenUpdating = True
End Sub

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

お礼

ありがとうございます。

回答No.1

nishi6

こんな感じでしょうか。

日付は昇順に並んでいるものとしています。並んでいないと、違った手順になります。

バックアップして試してください。

'シートのコードウィンドウ　（Excel2010）
Sub RowDelete()
　　Dim rw As Long '検索行カウンタ
　　Dim rwD As Long '削除行カウンタ

　　rw = 2　　'開始は2行目
　　While Cells(rw, 1) <> ""
　　　　'3行単位に調べる
　　　　rwD = rw + 3
　　　　While Cells(rw, 1) = Cells(rwD, 1)
　　　　　　'日付が一致したら
　　　　　　If Cells(rw, 3) = Cells(rwD, 3) And _
　　　　　　 Cells(rw + 1, 3) = Cells(rwD + 1, 3) And _
　　　　　　 Cells(rw + 2, 3) = Cells(rwD + 2, 3) Then
　　　　　　　　'内容が一致したら3行3列を削除して上に詰める
　　　　　　　　Range(Cells(rwD, 1), Cells(rwD + 2, 3)).Delete Shift:=xlUp
　　　　　　Else
　　　　　　　　'同じ日付で一致しなかったら次の3行を調べる
　　　　　　　　rwD = rwD + 3
　　　　　　End If
　　　　Wend

　　　　'次の3行（同じ日を調べることになるかもしれないが、まぁいいか）
　　　　rw = rw + 3
　　Wend
End Sub

お礼

ありがとうございます。