How to get the most recent file of each user.

[omairhe]

How do I get the most top or the most recent file of each user listed in range C2:C13 like below example:

Range C2:C13 =

04-2021 (user.one).xlsb

03-2021 (user.one).xlsb

03-2021 (user.two).xlsb

02-2021 (user.two).xlsb

01-2021 (user.one).xlsb

05-2021 (user.two).xlsb

12-2020 (user.one).xlsb

11-2020 (user.two).xlsb

10-2020 (user.one).xlsb

09-2020 (user.two).xlsb

08-2020 (user.one).xlsb

07-2020 (user.two).xlsb

Answers:
In D1 = 04-2021 (user.one).xlsb
In D2 = 05-2021 (user.two).xlsb

Thanks and will appreciate a lot.

 

[ranman256]

paste code into a vbe module then
run: PostUserMax

Private Function getUser(ByVal pvVal)
Dim vRet
Dim i As Integer
i = InStr(pvVal, "(")
If i > 0 Then vRet = Mid(pvVal, i)
getUser = vRet
End Function

Private Function getFileDate(ByVal pvVal)
Dim vRet, m, y
Dim i As Integer
i = InStr(pvVal, "(")
If i > 0 Then
  m = Left(pvVal, 2)
  y = Mid(pvVal, 4, 4)
  vRet = m & "/1/" & y
End If
getFileDate = vRet
End Function

Public Sub PostUserMax()
Dim col As New Collection
Dim sFile As String, sUser As String
Dim i As Integer
Dim vDate As Date
On Error GoTo errAdd
Range("d2:D55").Clear
Range("c2").Select
While ActiveCell.Value <> ""
    sFile = ActiveCell.Value
    sUser = getUser(sFile)
    vDate = getFileDate(sFile)
   
    If vDate > getFileDate(col(sUser)) Then
       col.Remove sUser
       col.Add sFile, sUser
    End If
   
    ActiveCell.Offset(1, 0).Select 'next row
Wend
Range("D1").Select
For i = 1 To col.Count
   ActiveCell.Value = col(i)
   ActiveCell.Offset(1, 0).Select 'next row
Next
Set col = Nothing
MsgBox "Done"
Exit Sub
errAdd:
Select Case Err
    Case 5, 457  'already exists
       Resume Next
    Case Else
     MsgBox Err.Description, , Err
End Select
Exit Sub
Resume
End Sub

 

[Kenneth Hobson]

My method gives the same result but with different data, the output order between the two methods can differ.

Sub Main()
  Dim a, d() As Double, u, q, f, i As Long, j As Long, r As Range, c As Range
  'Range with values like: 04-2021 (user.one).xlsb
  Set r = Range("C2", Cells(Rows.Count, "C").End(xlUp))
  a = WorksheetFunction.Transpose(r)
  'set size for date d and user u arrays.
  'ReDim d(1 To UBound(a))
  ReDim u(1 To UBound(a))
  'Parse user from cell strings in array a.
  For i = 1 To UBound(a)
    'd(i) = Left(a(i), InStr(a(i), " ("))
    u(i) = Mid(a(i), InStr(a(i), "(") + 1, InStr(a(i), ")") - InStr(a(i), "(") - 1)
  Next i
  'Unique users to array q.
  q = UniqueArrayByDict(u)
  Set c = [D1]
  For i = 0 To UBound(q)
    'Array a filtered by unique user.
    f = Filter(a, q(i), True, vbTextCompare)
    'Parse strings as dates from array f.
    ReDim d(0 To UBound(f))
    For j = 0 To UBound(f)
      'date array d by unique user.
      d(j) = CDate(Left(f(j), InStr(f(j), " (")))
    Next j
    'Filter array a by prefix with max(newest) date and unique user.
    c = Filter(a, Format(WorksheetFunction.Max(WorksheetFunction.Transpose(d)), "mm-yyyy") & " (" & q(i) & ")", True, vbTextCompare)(0)
    Set c = c.Offset(1)
  Next i
End Sub

'Early Binding method requires Reference: MicroSoft Scripting Runtime, scrrun.dll
Function UniqueArrayByDict(Array1d As Variant, Optional compareMethod As Integer = 0) As Variant
  Dim dic As Object 'Late Binding method - Requires no Reference
  Set dic = CreateObject("Scripting.Dictionary")  'Late or Early Binding method
  'Dim dic As Dictionary     'Early Binding method
  'Set dic = New Dictionary  'Early Binding Method
  Dim e As Variant
  dic.CompareMode = compareMethod
  'BinaryCompare=0
  'TextCompare=1
  'DatabaseCompare=2
  For Each e In Array1d
    If Not dic.Exists(e) Then dic.Add e, Nothing
  Next e
  UniqueArrayByDict = dic.Keys
End Function