Remove Duplicates (but keep one column)

[dylanpp]

Can anyone please explain how the following was done. I'm unsure whether a simple formula or excels standard functions were used.

Before: Random Data Clense _Master sheet2.xlsx (20.0 KB) (attached)
http://www.gamefront.com/files/20543509/Random+Data+Clense+_Master+sheet2.xlsx

The spreadsheet needed to be cleaned of duplicates but the extra column had to contain the unique IDs of duplicates removed.

After: Random Data Clense _Master sheet2_halfdone.xlsx (16.5 KB) (attached)
http://www.gamefront.com/files/20543512/Random+Data+Clense+_Master+sheet2_halfdone.xlsx

Thanks in advance!

 

[dylanpp]

If there's any hope of having this solved by tomorrow I'd owe ye all one!

 

[Datsmart]

This code will copy your data rows to worksheet "Sheet2".
It assumes you already have a Header row.

Sub CopyIDRows()
'Assign Variables
    TargetWS = Sheets("Sheet2").Name
    SourceWS = ActiveSheet.Name
    lrow = Sheets(TargetWS).Cells(Sheets(TargetWS).Rows.Count, 1).End(xlUp).Row
    'LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
    Lastrow = Range("D" & Rows.Count).End(xlUp).Row
'Sort Source WorkSheet via column D
    ActiveWorkbook.Worksheets(SourceWS).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(SourceWS).Sort.SortFields.Add Key:=Range("D2"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets(SourceWS).Sort
        .SetRange Range("A1:J" & Lastrow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
'Cycle through names, copy to worksheet "Sheet2"
    For i = 2 To Lastrow
        lrow = Sheets(TargetWS).Cells(Sheets(TargetWS).Rows.Count, 1).End(xlUp).Row + 1
        If Application.WorksheetFunction.CountIf(Range("D:D"), Range("D" & i)) = 1 Then
            'Copy Unique ID Row to next sheet
            Range("A" & i & ":F" & i).Copy Sheets(TargetWS).Cells(lrow, 1)
            Sheets(TargetWS).Cells(lrow, "G").Value = Range("A" & i).Value
        Else
            'Copy Duplicate ID number row
            If Sheets(TargetWS).Cells(lrow - 1, "D").Value = Range("D" & i).Value Then
                lcol = Sheets(TargetWS).Cells(lrow - 1, Sheets(TargetWS).Columns.Count).End(xlToLeft).Column + 1
                Sheets(TargetWS).Cells(lrow - 1, lcol).Value = Range("A" & i).Value
            Else
                'Copy ID number to previous entry row
                lcol = Sheets(TargetWS).Cells(1, Sheets(TargetWS).Columns.Count).End(xlToLeft).Column + 1
                Range("A" & i & ":F" & i).Copy Sheets(TargetWS).Cells(lrow, 1)
                Sheets(TargetWS).Cells(lrow, lcol).Value = Range("A" & i).Value
            End If
        End If
    Next i
End Sub

Code Sorts Active Table via "Contact Name" column, then begins copying row data to Sheet2.