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

Question

Since I am new to VBA excel, I don’t have a clue of how to tackle the following issue.

I have created a user entry form with which users can enter project details. Whenever project details need to be updated, this user entry form can be used. These entries will be stored in another sheet called “Project Update History”. This list contains all the update entries for every project (as shown in the table below).

/--------------------------------------------------------------\
|      |  EntryDate    | Project Name | Project ID | Status    |
|--------------------------------------------------------------|
|  1   | 01.02.2018    | ABC          |   P001     |  text     |
|--------------------------------------------------------------|
|  2   | 01.02.2018    | CDE          |   P002     |  text     |
|--------------------------------------------------------------|
|  3   | 15.02.2018    | CDE          |   P002     |  text     |
|--------------------------------------------------------------|
|  4   | 16.02.2018    | FGH          |   P003     |  text     |
|--------------------------------------------------------------|
|  5   | 08.08.2018    | ABC          |   P001     |  text     |
|--------------------------------------------------------------|
|  6   | 09.09.2019    | FGH          |   P003     |  text     |
|--------------------------------------------------------------|
|  7   | 14.09.2019    | FGH          |   P003     |  text     |
|--------------------------------------------------------------|
|  8   | 12.12.2019    | CDE          |   P002     |  text     |
\--------------------------------------------------------------/

enter image description here

As you can imagine, there are hundreds of entries and it’s quite difficult to get an overview. Ideally, there is a list in a separate sheet with latest project status only. (see table below)

/--------------------------------------------------------------\
|      |  EntryDate    | Project Name | Project ID | Status    |
|--------------------------------------------------------------|
|  1   | 08.08.2018    | ABC          |   P001     |  text     |
|--------------------------------------------------------------|
|  2   | 14.09.2019    | FGH          |   P003     |  text     |
|--------------------------------------------------------------|
|  3   | 12.12.2019    | CDE          |   P002     |  text     |
\--------------------------------------------------------------/

enter image description here

In order to get this, I already tried different options such as using “filters” or “array formulas”. However, both were rather dissatisfactory. Filters were not really helpful, as I want to see all the projects at once (but just the most recent project updates). Array formulas actually gave me the output, I wanted … but the excel file became very slow. (To get the latest entry date {=MAX(IF(‘Project Update History’!C:C=C4,’Project Statuses’!B:B,0))} (To get the corresponding entry details an INDEX Match formula.)

So the only way, I could avoid this problem is to use macros. My idea is to have a button that will search for the latest status of each project and display in a sheet… but I really don’t know how to code this… Maybe someone else has also encountered this issue and found a solution for it? I would really apprecitate any help from you. :)

Many thanks in advance for your help.

Niro

Answer 1

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:

---

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