How to get the most recent file of each user.

omairhe

Well-known Member
Joined
Mar 26, 2009
Messages
2,018
Office Version
  1. 2019
Platform
  1. Windows
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.
 

Excel Facts

What did Pito Salas invent?
Pito Salas, working for Lotus, popularized what would become to be pivot tables. It was released as Lotus Improv in 1989.

ranman256

Well-known Member
Joined
Jun 17, 2014
Messages
1,980
paste code into a vbe module then
run: PostUserMax

Code:
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

Well-known Member
Joined
Feb 6, 2007
Messages
3,177
Office Version
  1. 365
Platform
  1. Windows
My method gives the same result but with different data, the output order between the two methods can differ.

VBA Code:
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
 

Watch MrExcel Video

Forum statistics

Threads
1,130,119
Messages
5,640,219
Members
417,131
Latest member
Seanr19871

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top