[Solved] How to find latest entry for each group and display in a separate sheet in Excel

by


Here is one way using arrays. Depending on the size of your data you may hit a limit with Transpose, in which case I can re-write part of the solution.

I have used “,” delimiter to keep track of separate column items when concatenating together.You may wish to swop this with a symbol you do not expect to find in your data to ensure you do not end up with unexpected results.
Change the value here, Const DELIMITER As String = "," , if changing the delimiter.

Option Explicit
Public Sub GetLastDateInfo()
    Application.ScreenUpdating = False
    Const DELIMITER As String = ","
    Dim arr(), resultsArr(), dict As Object, i As Long, currDate As Long, ws As Worksheet, headers()
    headers = Array("Entry Date", "Project Date", "Project ID", "Status")
    Set ws = ThisWorkbook.Worksheets("Sheet1"): Set dict = CreateObject("Scripting.Dictionary")
    arr = ws.Range("A2:D" & GetLastRow(ws, 1)).Value
    ReDim resultsArr(1 To UBound(arr, 1), 1 To UBound(arr, 2))

    For i = LBound(arr, 1) To UBound(arr, 1)
        currDate = CLng(CDate(Replace$(arr(i, 1), ".", "-")))
        If Not dict.Exists(arr(i, 2) & DELIMITER & arr(i, 3)) Then
            dict.Add arr(i, 2) & DELIMITER & arr(i, 3), currDate & DELIMITER & arr(i, 4)
        ElseIf Split(dict(arr(i, 2) & DELIMITER & arr(i, 3)), DELIMITER)(0) < currDate Then
            dict(arr(i, 2) & DELIMITER & arr(i, 3)) = currDate & DELIMITER & arr(i, 4)
        End If
    Next i
    Dim key As Variant, r As Long, tempArr() As String
    For Each key In dict.keys
        r = r + 1
        tempArr = Split(dict(key), DELIMITER)
        resultsArr(r, 1) = tempArr(0)
        resultsArr(r, 4) = tempArr(1)
        tempArr = Split(key, DELIMITER)
        resultsArr(r, 2) = tempArr(0)
        resultsArr(r, 3) = tempArr(1)
    Next key
    resultsArr = Application.WorksheetFunction.Transpose(resultsArr)
    ReDim Preserve resultsArr(1 To UBound(resultsArr, 1), 1 To r)
    resultsArr = Application.WorksheetFunction.Transpose(resultsArr)
    With Worksheets("Sheet2")
        .Range("A1").Resize(1, UBound(headers) + 1) = headers
        .Range("A2").Resize(UBound(resultsArr, 1), UBound(resultsArr, 2)) = resultsArr
    End With
    Application.ScreenUpdating = True
End Sub

Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
    With ws
        GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row
    End With
End Function

Output:

output

Adapted for increased number of columns ( uses GetLastRow function from above):

 Public Sub GetLastDateInfo2()
    Application.ScreenUpdating = False
    Const DELIMITER As String = ","
    Dim arr(), resultsArr(), dict As Object, dict2 As Object, i As Long, j As Long
    Dim currDate As Long, ws As Worksheet, headers()
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    headers = ws.Range("A1:AN1").Value
    headers = Application.WorksheetFunction.Index(headers, 1, 0)
    Set dict = CreateObject("Scripting.Dictionary"): Set dict2 = CreateObject("Scripting.Dictionary")
    arr = ws.Range("A2:AN" & GetLastRow(ws, 1)).Value
    ReDim resultsArr(1 To UBound(arr, 1), 1 To UBound(arr, 2))

    For i = LBound(arr, 1) To UBound(arr, 1)
        currDate = CLng(CDate(Replace(arr(i, 1), ".", "-")))
        If Not dict.Exists(arr(i, 2) & DELIMITER & arr(i, 3)) Then
            dict.Add arr(i, 2) & DELIMITER & arr(i, 3), currDate
            dict2.Add arr(i, 2) & DELIMITER & arr(i, 3), arr(i, 4)
            For j = 5 To UBound(arr, 2)
                dict2(arr(i, 2) & DELIMITER & arr(i, 3)) = dict2(arr(i, 2) & DELIMITER & arr(i, 3)) & DELIMITER & arr(i, j)
            Next j
        ElseIf Split(dict(arr(i, 2) & DELIMITER & arr(i, 3)), DELIMITER)(0) < currDate Then
            dict(arr(i, 2) & DELIMITER & arr(i, 3)) = currDate
            dict2(arr(i, 2) & DELIMITER & arr(i, 3)) = vbNullString
            For j = 4 To UBound(arr, 2)
                dict2(arr(i, 2) & DELIMITER & arr(i, 3)) = dict2(arr(i, 2) & DELIMITER & arr(i, 3)) & DELIMITER & arr(i, j)
            Next j
        End If
    Next i
    Dim key As Variant, r As Long, tempArr() As String

    For Each key In dict.keys
        r = r + 1
        tempArr = Split(dict(key), DELIMITER)
        resultsArr(r, 1) = tempArr(0)
        tempArr = Split(key, DELIMITER)
        resultsArr(r, 2) = tempArr(0)
        resultsArr(r, 3) = tempArr(1)
        resultsArr(r, 4) = Replace$(dict2(key), DELIMITER, vbNullString, , 1)
    Next key
    resultsArr = Application.WorksheetFunction.Transpose(resultsArr)
    ReDim Preserve resultsArr(1 To UBound(resultsArr, 1), 1 To r)
    resultsArr = Application.WorksheetFunction.Transpose(resultsArr)
    Application.DisplayAlerts = False
    With Worksheets("Sheet2")
         .UsedRange.ClearContents
        .Range("A2").Resize(UBound(resultsArr, 1), UBound(resultsArr, 2)) = resultsArr
        .Columns("D").TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote,Other:=True, OtherChar _
        :=DELIMITER, TrailingMinusNumbers:=True
        .Range("A1").Resize(1, UBound(headers)) = headers
    End With
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

9

solved How to find latest entry for each group and display in a separate sheet in Excel