Macro to Copy and Paste Rows in another sheet based on the Latest date value

[deegosh]

Good Morning all,

Huge thanks in advance for anyone who helps. My VBA knowledge is basic to none

I have Name and Date Columns in one Sheet and around 10000 records with repeated Names with dates(sheet1). I need to get the latest date and the count of occurrences in corresponding Name in a new sheet. below is a small example. It will summarize and expect less number of records on sheet 2.

Sheet 1						Sheet 2
Name	Date					Name	Latest Date	Occurrence count
John	11/14/2013​					John	8/4/2014​	3​
Gorden	11/14/2013​					Gorden	11/14/2013​	2​
Gorden	11/14/2013​					Jim	8/4/2015​	2​
John	8/4/2014​					Andy	7/6/2017​	2​
Jim	8/4/2014​					Helly	8/4/2014​	1​
Andy	7/25/2016​
Helly	8/4/2014​
Jim	8/4/2015​
John	8/4/2014​
Andy	7/6/2017​

 

[bebo021999]

Try:

Option Explicit
Sub test()
Dim lr&, i&, rng, name As String, r, arr(1 To 100000, 1 To 3)
Dim dic As Object
Set dic = CreateObject("Scripting.dictionary")
Application.ScreenUpdating = False
With Worksheets("Sheet1")
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    rng = .Range("A2:B" & lr).Value
End With
    For i = 1 To lr - 1
        name = rng(i, 1)
        If Not dic.exists(name) Then
            dic.Add name, Array(rng(i, 2), 1)
        Else
            r = dic(name)
            r(0) = WorksheetFunction.Max(r(0), rng(i, 2))
            r(1) = r(1) + 1
            dic(name) = r
        End If
    Next
    For i = 1 To dic.Count
        arr(i, 1) = dic.keys()(i - 1)
        arr(i, 2) = dic.items()(i - 1)(0)
        arr(i, 3) = dic.items()(i - 1)(1)
    Next
With Worksheets("Sheet2")
    .Range("A1:C1").Value = Array("Name", "Latest Date", "Occurence count")
    .Range("A2:C100000").ClearContents
    .Range("B2:B100000").NumberFormat = "mm/dd/yyyy"
    .Range("A2").Resize(i, 3).Value = arr
End With
Application.ScreenUpdating = True
End Sub

 

[deegosh]

Option Explicit
Sub test()
Dim lr&, i&, rng, name As String, r, arr(1 To 100000, 1 To 3)
Dim dic As Object
Set dic = CreateObject("Scripting.dictionary")
Application.ScreenUpdating = False
With Worksheets("Sheet1")
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    rng = .Range("A2:B" & lr).Value
End With
    For i = 1 To lr - 1
        name = rng(i, 1)
        If Not dic.exists(name) Then
            dic.Add name, Array(rng(i, 2), 1)
        Else
            r = dic(name)
            r(0) = WorksheetFunction.Max(r(0), rng(i, 2))
            r(1) = r(1) + 1
            dic(name) = r
        End If
    Next
    For i = 1 To dic.Count
        arr(i, 1) = dic.keys()(i - 1)
        arr(i, 2) = dic.items()(i - 1)(0)
        arr(i, 3) = dic.items()(i - 1)(1)
    Next
With Worksheets("Sheet2")
    .Range("A1:C1").Value = Array("Name", "Latest Date", "Occurence count")
    .Range("A2:C100000").ClearContents
    .Range("B2:B100000").NumberFormat = "mm/dd/yyyy"
    .Range("A2").Resize(i, 3).Value = arr
End With
Application.ScreenUpdating = True
End Sub

Try:

Option Explicit
Sub test()
Dim lr&, i&, rng, name As String, r, arr(1 To 100000, 1 To 3)
Dim dic As Object
Set dic = CreateObject("Scripting.dictionary")
Application.ScreenUpdating = False
With Worksheets("Sheet1")
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    rng = .Range("A2:B" & lr).Value
End With
    For i = 1 To lr - 1
        name = rng(i, 1)
        If Not dic.exists(name) Then
            dic.Add name, Array(rng(i, 2), 1)
        Else
            r = dic(name)
            r(0) = WorksheetFunction.Max(r(0), rng(i, 2))
            r(1) = r(1) + 1
            dic(name) = r
        End If
    Next
    For i = 1 To dic.Count
        arr(i, 1) = dic.keys()(i - 1)
        arr(i, 2) = dic.items()(i - 1)(0)
        arr(i, 3) = dic.items()(i - 1)(1)
    Next
With Worksheets("Sheet2")
    .Range("A1:C1").Value = Array("Name", "Latest Date", "Occurence count")
    .Range("A2:C100000").ClearContents
    .Range("B2:B100000").NumberFormat = "mm/dd/yyyy"
    .Range("A2").Resize(i, 3).Value = arr
End With
Application.ScreenUpdating = True
End Sub

Thank You So Much! It Worked like a charm.