Transfer most Recent Records

0
59

The ExcelHelpDesk Support team received the following request for help

Problem – Identify the most Recent Records in a Worksheet

I have a workbook that has one sheet, The sheet lists each ID with multiple records of DATE. Could you kindly inform me how to get the “earliest date” for each ID, so the table in Sheet1 will become the table in Sheet2?

I was following the steps from http://excelhelpdesk.com/functions/vlookup-search-earliest-date/ but I was not able to get the full result to Sheet2. I only get the earliest date to Sheet2 > B2. On Sheet2 when I copied B2 to B3, I got the same date result which was not what I wanted.

It would be so great that you can help with showing the result on Sheet2 and the formula on Sheet2.

For this problem we received a sample workbook. See the screen shot below of the worksheet that was the starting point for the data that needed to be transferred. As you can see the data includes multiple rows of data for the same ID and DATE. This request needed to firstly identify the records that were a unique set and then to only transfer the first record for that set to a Result worksheet.

In the screen shot below we have highlighted the records that were not to be transferred to the Result worksheet.

 

Step 1 – Clean up Data

To acheive the transfer a Macro has been developed that will first “clean” the data and then sort it ready for comparison. Finally it will transfer the data to the “Result” worksheet. The sample file supplied included for each DATE value in the Column B an ‘ character in front of the date. Effectively this told Excel to ignore this a date and treat it as TEXT.

The first step in our macro was to remove that ‘ character and format the cell to a DATE format.

Step 2 – Sort the Data for Transfer

The next step was to sort the data into ID and DATE order for a comparison to occur. This is acheived by setting an appropriate range within the Worksheet and then using .Cells.Sort to re-order the list.

Step 3 – Lastly the Compare and Transfer

Lastly the rows are stepped through one by one to compare for duplicate ID / DATE combinations. As a new combination is found it is transferred to the Result Worksheet.

Now for the VBA script that performs this transfer. You will see that the From Worksheet and To Worksheet are constants and need to be varied if you are not using worksheets with these names. The starting cell is also set to A1 and this can be changed by modifying the constant below.

Option Explicit

Sub TransferRecentRecord()
'This routine will transfer the most recent record from one Worksheet list of many records
'To another Worksheet

Const wsFromWorksheet = "Sheet1"
Const wsToWorksheet = "Result"
Const strStartRange = "A1"

Dim wsSourceWorksheet As Worksheet
Dim wsResultWorksheet As Worksheet
Dim myRange As Range
Dim myResultRange As Range
Dim i As Long
Dim j As Long
Dim dtePreviousDate As Date
Dim strPreviousID As String

Set wsSourceWorksheet = ThisWorkbook.Worksheets(wsFromWorksheet)
Set wsResultWorksheet = ThisWorkbook.Worksheets(wsToWorksheet)

'First lets remove the ' character from each date cell in the Source if it exists
Set myRange = wsSourceWorksheet.Range(strStartRange)
i = 1
Do While myRange.Offset(i, 0).Value <> ""
If Not myRange.Offset(i, 1).NumberFormat = "yyyy-mm-dd" Then
myRange.Offset(i, 1).NumberFormat = "yyyy-mm-dd"
myRange.Offset(i, 1).Value = Replace(myRange.Offset(i, 1).Value, "'", "")
End If
i = i + 1
Loop

'Now sort the Source records by Date Descending
Set myRange = wsSourceWorksheet.Range(strStartRange)
Set myRange = Range(myRange, myRange.End(xlToRight))
Set myRange = Range(myRange, myRange.End(xlDown))
With myRange
.Cells.Sort Key1:=.Columns(1), Order1:=xlAscending, Header:=xlYes, _
Key1:=.Columns(2), Order1:=xlAscending
End With

'Now transfer the most recent records to the Result worksheet
wsResultWorksheet.Cells.Clear
Set myResultRange = wsResultWorksheet.Range(strStartRange)
Set myRange = wsSourceWorksheet.Range(strStartRange)
dtePreviousDate = #1/1/1901#
strPreviousID = ""
i = 0
j = 0
Do While myRange.Offset(i, 0).Value <> ""

'Transfer the Heading Row
If i = 0 Then
myRange.Offset(i, 0).EntireRow.Copy
myResultRange.Offset(j, 0).PasteSpecial
j = j + 1

'Check if we need to Transfer this Detail Row
Else

If dtePreviousDate <> myRange.Offset(i, 1).Value Or _
strPreviousID <> myRange.Offset(i, 0).Value Then
myRange.Offset(i, 0).EntireRow.Copy
myResultRange.Offset(j, 0).PasteSpecial
dtePreviousDate = myRange.Offset(i, 1).Value
strPreviousID = myRange.Offset(i, 0).Value
j = j + 1
End If
End If
i = i + 1
Loop

End Sub

 

Use this in your Own Workbook

If you have a similar need as described in this workbook you can apply to your situation by modifying the Constant values at the start of the script and also ensuring that the columns you need to sort and match on are updated in the sections of the macro performing those steps.

To help you get started here is a link to a Sample Workbook that includes the Macro discussed above.

Download Sample Workbook

If you have a question on this post for the Excel Help Desk team or have something you would like to share on this topic then please leave a comment