Pulling out the latest records ONLY. VBA

Hi there,

I have attached the file.

What I would like to do:

For each record in column A of "test" worksheet, I want to keep the the ones with the latest date. So in "output" worksheet, you will see ONLY those records with the latest date.

Sometimes, there can be up to 3 or 4 lines for the same record, with each line showing different dates, but I only want the latest date, which is the last one for the record.

Can this be done using a macro of some sort?

Guidance or comment is much appreciated.

Thanks

Give this a try

Sub abc()
 Dim a, i As Long
 
 With Worksheets("test")
    a = .Range("a1", .Cells(Rows.Count, "a").End(xlUp).Offset(, 1))
 End With
 
 With CreateObject("scripting.dictionary")
    .comparemode = 1
    For i = 1 To UBound(a)
        If Not .exists(a(i, 1)) Then
            .Item(a(i, 1)) = a(i, 1) & ";" & a(i, 2)
        Else
            If Split(.Item(a(i, 1)), ";")(1) > a(i, 2) Then
                .Item(a(i, 1)) = a(i, 1) & ";" & a(i, 2)
            End If
        End If
    Next
    a = .items
 End With
 
 With Worksheets("output")
    .cells.delete
    For i = 0 To UBound(a)
        .Cells(i + 1, 1).Resize(, 2) = Split(a(i), ";")
    Next
 End With
End Sub

What does 1 represent? 1 is just the normal default code used in this example?

If the CompareMode is TextCompare (1) the comparison is case-insensitive, while it is case-sensitive if the CompareMode is BinaryCompare (0).

What does .exists(a(i,1)) mean?

Use it to check if a given key is already in use in the dictionary

.Item(a(i, 1)) = a(i, 1) & ";" & a(i, 2)

.item(key) = a(i, 1) & ";" & a(i, 2) Value for that key. ";" Is used like columns. "AB1/12";"1-Jul-12"




Here's an good link
http://www.vbusers.com/code/codeget....D=524&PostID=1

See if this help

    First time it finds AB1/12
    If Not .exists(AB1/12) Then
        .Item(AB1/12) = AB1/12 & ";" & 7/1/2012
    Else Second time it finds AB1/12
        '->(0)AB1/12";"7/1/2012 '<--(1)				
        If Split(.Item(AB1/12), ";")(1) > 7/29/2012 Then
            .Item(AB1/12) = AB1/12 & ";" & 7/29/2012
        End If
    End I

Here's a different approach

Sub ForFUn()
Dim wsOutput As Worksheet
Dim LR As Long

ThisWorkbook.Worksheets("Test").Copy , Worksheets(Sheets.Count)

Set wsOutput = Worksheets(Sheets.Count)
With wsOutput
    .Cells(1, 1).CurrentRegion.Copy .Cells(1, 5)
LR = .Cells(Rows.Count, 5).End(xlUp).Row
    .Range("B2:B1000").ClearContents
    .Columns("A").RemoveDuplicates 1, xlYes
    .Range("B2").FormulaArray = "=MAX(IF($E$2:$E$" & LR & "=A2,$F$2:$F$" & LR & "))"
    .Range("B2").AutoFill .Range("B2:B" & .Cells(Rows.Count, 1).End(xlUp).Row)
    .Columns("B").Copy
    .Columns("B").PasteSpecial xlPasteValues
    .Columns("E:F").Delete
End With

Application.CutCopyMode = False
End Sub

Yet anoher way

Sub Abc_v2()
Dim LR As Long
Dim ws As Worksheet

Set ws = Worksheets("output")

Application.ScreenUpdating = False
With Worksheets("Test").Range("a1")
    .CurrentRegion.Copy ws.Range("a1")
End With

With ws
    .Cells.WrapText = False
    With .Sort
        .SortFields.Clear
        .SortFields.Add Key:=ws.Range("B1"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortTextAsNumbers
        .SetRange ws.Range("A1").CurrentRegion
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    .Range("a1").CurrentRegion.RemoveDuplicates 1, xlYes
    With .Sort
        .SortFields.Clear
        .SortFields.Add Key:=ws.Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
        .SetRange ws.Range("A1").CurrentRegion
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End With
Application.ScreenUpdating = True
End Sub

.Cells(i + 1, 1).Resize(, 2) = Split(a(i), ";")

When we split a(i) we will have 2 columns. So Resize(0 Rows,2 Columns)
1 = AB1/12 ";" 2 = 7/1/2012


And here's another good link

http://www.experts-exchange.com/Soft...ss-in-VBA.html

There reason for offset at the end is to make the Range("a2:b and whatever is the last row is in column A). I didnt know if column A and B would have the same last row so I get the lastrow in column A and use offset(0 rows, 1 column)

a = .Range("a1", .Cells(Rows.Count, "a").End(xlUp).Offset(, 1))

If Column A and Column B would have the same last row then we could use

a = .Range("a1", .Cells(Rows.Count, "b").End(xlUp))

And what would you want the output to be? The same columns as before or include all columns?

Something like this. Not to much modifictions

Option Explicit

Sub abc()
 Dim a, i As Long
 
 With Worksheets("test")
    a = .Range("a1", .Cells(Rows.Count, "e").End(xlUp))
 End With
 
 With CreateObject("scripting.dictionary")
    .comparemode = 1
    For i = 1 To UBound(a)
        If Not .exists(a(i, 1)) Then
            '.Item(a(i, 1)) = a(i, 1) & ";" & a(i, 2) & ";" & a(i, 3) & ";" & a(i, 4) & ";" & a(i, 5)
            'below is the same as above but using join function.
            .Item(a(i, 1)) = Join(Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4), a(i, 5)), ";")
        Else
            If Split(.Item(a(i, 1)), ";")(3) > a(i, 3) Then
                .Item(a(i, 1)) = Join(Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4), a(i, 5)), ";")
            End If
        End If
    Next
    a = .items
 End With
 
 With Worksheets("output")
    For i = 0 To UBound(a)
        .Cells(i + 1, 1).Resize(, 5) = Split(a(i), ";")
    Next
 End With
End Sub

Split(.Item(a(i, 1)), ";")(2) > a(i, 3)

Actually the 3 needs to be 2 my bad. Because when you split the item it is 0 based array.

0 ; 1 ; 2 ; 3 ; 4
AB1/12;names;29-Jul-12;gender;test

(0) = AB1/12
(1) = names
(2) = 29-Jul-12
(3) = gender
(4) = test

I noticed also you have this in the worksheets module. I would remove it from there and place it into a standard Module.

Yes your correct the split would be

Split(.Item(a(i, 1)), ";")(4) > a(i, 5)