Code:Public Function DuplicateData()Dim ws As Worksheet Dim current As String Dim lastrow As Long Dim nextrow As Long Dim i As Long Set ws = Worksheets("duplicates") With ws .UsedRange.ClearContents .Range("A3:E3").Value = Array("Ingredient", "Date 1", "Date 2", "Date 3", "package") End With Worksheets("master data").Copy AFter:=Worksheets(Worksheets.Count) With ActiveSheet .Name = "temp" .Range("G1").Value = "Flag" nextrow = 4 lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row .Range("G2").Resize(lastrow - 1).Formula = _ "=IF(COUNTIF(E$1:E2,E2)>1,INDEX(G$1:G1,MATCH(E2,E$1:E1,0)),MAX(G$1:G1)+1)" .Columns("A:G").Sort key1:=Range("G2"), order1:=xlAscending, Header:=xlYes For i = 2 To lastrow If Application.CountIf(.Columns("E"), .Cells(i, "E").Value) > 1 Then current = .Cells(i, "E").Value ws.Cells(nextrow, "A").Value = current Do While .Cells(i, "E").Value = current .Cells(i, "B").Resize(, 3).Copy ws.Cells(nextrow, "B") .Cells(i, "A").Copy ws.Cells(nextrow, "E") nextrow = nextrow + 1 i = i + 1 Loop nextrow = nextrow + 1 i = i - 1 End If Next i End With Application.DisplayAlerts = False Worksheets("temp").Delete End Function
Bookmarks