Macro To Find Latest Date To Corresponding Data In Column B And Add To Sheet 2

Dazzawm

Well-known Member
Joined
Jan 24, 2011
Messages
3,783
Office Version
  1. 365
Platform
  1. Windows
I have a list of data in column A & B on sheet 1. I need a macro to find the latest date in column A and add to sheet 2 for each corresponding number in column B onto sheet 2 please. Example below with highlighted last dates for each in yellow.

SMP002.xlsx
AB
1DateStock Code
205/01/2024FP86410
310/01/2024FP86410
422/02/2024FP86410
529/02/2024FP86410
611/04/2024FP86410
725/04/2024FP86410
831/05/2024FP86410
931/05/2024FP86410
1007/06/2024FP86410
1111/01/2024FPAB1167
1222/02/2024FPAB1167
1304/04/2024FPAB1167
1408/02/2024FPAB1196
1525/01/2024FPAB1208
1622/02/2024FPAB1208
1728/02/2024FPAB1208
1806/03/2024FPAB1208
1907/03/2024FPAB1208
2029/04/2024FPAB1208
2110/05/2024FPAB1208
2224/05/2024FPAB1208
2324/05/2024FPAB1208
2405/01/2024FPAB1212
2522/02/2024FPAB1212
2622/02/2024FPAB1246
2704/04/2024FPAB1266
2824/05/2024FPAB1266
2907/02/2024FPAB1307
3017/04/2024FPAB1307
3111/01/2024FPAB1309
Sheet1


Result after code

SMP002.xlsx
AB
1DateStock Code
207/06/2024FP86410
304/04/2024FPAB1167
424/05/2024FPAB1208
522/02/2024FPAB1212
624/05/2024FPAB1266
717/04/2024FPAB1307
811/01/2024FPAB1309
Sheet2


It would be a help if sheet 2 was created also please.


EDIT:
I forgot to add row 14 and 26 in the examples.
 
Last edited by a moderator:

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.
Try this:
VBA Code:
Sub Dazzawm_1()
Dim i As Long, j As Long, k As Long
Dim va, vb
Dim dt As Date
Sheets("Sheet1").Activate  'change sheet name to suit
n = Range("A" & Rows.Count).End(xlUp).Row
va = Range("A1:B" & n + 1) 'n + 1 because I need to add 1 blank cell, otherwise if last cell is unique then
                           'the last i will get "Subscript out of range" on va(i + 1, 1)

ReDim vb(1 To UBound(va, 1), 1 To 2)
k = 1
For i = 2 To UBound(va, 1) - 1
    dt = va(i, 1)
    Do While va(i, 2) = va(i + 1, 2)
        i = i + 1
        If dt < va(i, 1) Then dt = va(i, 1)
    Loop
    k = k + 1
    vb(k, 2) = va(i, 2)
    vb(k, 1) = dt
Next

Sheets("Sheet2").Range("A1").Resize(k, 2) = vb  ''change sheet name to suit
End Sub
Result :
Book1 (version 1).xlsb
AB
1
207/06/2024FP86410
304/04/2024FPAB1167
408/02/2024FPAB1196
524/05/2024FPAB1208
622/02/2024FPAB1212
722/02/2024FPAB1246
824/05/2024FPAB1266
917/04/2024FPAB1307
1011/01/2024FPAB1309
11
Sheet2
 
Upvote 0
Try this:
VBA Code:
Sub Dazzawm_1()
Dim i As Long, j As Long, k As Long
Dim va, vb
Dim dt As Date
Sheets("Sheet1").Activate  'change sheet name to suit
n = Range("A" & Rows.Count).End(xlUp).Row
va = Range("A1:B" & n + 1) 'n + 1 because I need to add 1 blank cell, otherwise if last cell is unique then
                           'the last i will get "Subscript out of range" on va(i + 1, 1)

ReDim vb(1 To UBound(va, 1), 1 To 2)
k = 1
For i = 2 To UBound(va, 1) - 1
    dt = va(i, 1)
    Do While va(i, 2) = va(i + 1, 2)
        i = i + 1
        If dt < va(i, 1) Then dt = va(i, 1)
    Loop
    k = k + 1
    vb(k, 2) = va(i, 2)
    vb(k, 1) = dt
Next

Sheets("Sheet2").Range("A1").Resize(k, 2) = vb  ''change sheet name to suit
End Sub
Result :
Book1 (version 1).xlsb
AB
1
207/06/2024FP86410
304/04/2024FPAB1167
408/02/2024FPAB1196
524/05/2024FPAB1208
622/02/2024FPAB1212
722/02/2024FPAB1246
824/05/2024FPAB1266
917/04/2024FPAB1307
1011/01/2024FPAB1309
11
Sheet2
Thanks would the code be able to create sheet 2 if not already there and add headers of 'Date' in A1 and 'Stock Code' in B1 please.
 
Upvote 0
try
Code:
Sub test()
    Dim a, i As Long
    a = Sheets("sheet1").[a1].CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(a, 1)
            If Not .exists(a(i, 2)) Then
                .Item(a(i, 2)) = a(i, 1)
            Else
                If .Item(a(i, 2)) < a(i, 1) Then .Item(a(i, 2)) = a(i, 1)
            End If
        Next
        a = Application.Transpose(Array(.items, .keys))
    End With
    If Not [isref(sheet2!a1)] Then Sheets.Add(, Sheets(Sheets.Count)).Name = "Sheet2"
    With Sheets("sheet2").[a1].Resize(UBound(a, 1), UBound(a, 2))
        .CurrentRegion.ClearContents
        .Value = a
    End With
End Sub
 
Upvote 1
Solution
try
Code:
Sub test()
    Dim a, i As Long
    a = Sheets("sheet1").[a1].CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(a, 1)
            If Not .exists(a(i, 2)) Then
                .Item(a(i, 2)) = a(i, 1)
            Else
                If .Item(a(i, 2)) < a(i, 1) Then .Item(a(i, 2)) = a(i, 1)
            End If
        Next
        a = Application.Transpose(Array(.items, .keys))
    End With
    If Not [isref(sheet2!a1)] Then Sheets.Add(, Sheets(Sheets.Count)).Name = "Sheet2"
    With Sheets("sheet2").[a1].Resize(UBound(a, 1), UBound(a, 2))
        .CurrentRegion.ClearContents
        .Value = a
    End With
End Sub
Thanks that works great. How does it add headers on sheet 2, I don't see that in your code?
 
Upvote 0
Because adding data from Row1(Header) to dictionary object.
 
Upvote 0

Forum statistics

Threads
1,223,882
Messages
6,175,165
Members
452,615
Latest member
bogeys2birdies

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
Back
Top