Keeping first two instances in a column of duplicates in excel - excel

Question

I have a long list of items where some are duplicate identification numbers in one column. The records are not duplicates all across the spreadsheet. I am looking to extract the first two rows from the first two iterations of duplicate numbers when sorted by a different value (time/date).
I've seen topics on keeping the first instance of duplicate items, but not keeping the first two instances in records. I'm looking for a formula or vba.
Thanks

Answer 1

First sort your records so that the ones you want to keep are higher up the column.
Add a column where you'll put the formula (I'm assuming the first ID number is in cell A1):
=COUNTIF($A$1:A1, A1)
Drag the formula to the bottom of the table and copy/paste values in place to remove the formula.
Insert a filter and you can filter on only the results of 1 and 2 to get the first two instances of the ID numbers. Copy to a fresh spreadsheet to get only those in a sheet.

Answer 2

Here is a subroutine that should do what you are asking, you will need to alter it to your specific data as it assumes that columns A to G hold the data you want to extract and that column A has the duplicate data, column B holds the other data you want to sort by and that there are no empty cells in the data for column A.
Sub SortAndExctract()
Dim wsInputWorksheet As Worksheet
Dim wsOutputWorksheet As Worksheet
Dim lInputRowNumber As Long
Dim lOutputRowNumber As Long
Dim sLastExtract As Variant 'A variant as I don't know what type of value you are looking for
Dim iColumnCounter As Integer
'Sort the worksheet, assumes that the columns are in the range A:G and that you
'Want to sort according to column A and then column B
Range("A:G").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, _
Key2:=Range("B1"), Order2:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Set wsInputWorksheet = ThisWorkbook.ActiveSheet
Set wsOutputWorksheet = ThisWorkbook.Worksheets.Add
lInputRowNumber = 1
lOutputRowNumber = 1
'Until an empty cell is found check for duplicate values in column A
'Assumes that you don't have empty cells in column A within your data
'and that the duplicate values are in column A
Do While wsInputWorksheet.Cells(lInputRowNumber, 1).Value <> Empty
If wsInputWorksheet.Cells(lInputRowNumber, 1).Value <> sLastExtract Then
If wsInputWorksheet.Cells(lInputRowNumber, 1).Value = wsInputWorksheet.Cells(lInputRowNumber + 1, 1).Value Then
For iColumnCounter = 1 To 6 'Assuming againg that colum G is the last column
'copy cells to output worksheet
wsOutputWorksheet.Cells(lOutputRowNumber, iColumnCounter).Value = _
wsInputWorksheet.Cells(lInputRowNumber, iColumnCounter).Value
wsOutputWorksheet.Cells(lOutputRowNumber + 1, iColumnCounter).Value = _
wsInputWorksheet.Cells(lInputRowNumber + 1, iColumnCounter).Value
Next iColumnCounter
lInputRowNumber = lInputRowNumber + 1 'Will be incremented again later
lOutputRowNumber = lOutputRowNumber + 2
End If
End If
lInputRowNumber = lInputRowNumber + 1
Loop
End Sub