VBA macro to order and delete information

[Akire87]

Hi!
I'm working with VBA and excel 2016 and is trying to create a macro that should order and delete information that I do not need.

My data looks similar to bellow.

	Blue	Yellow	Orange	Green
AAA	Blue#05/02 15:02 school	Yellow#05/03 12:05 home	Orange#05/01 13:00 park	Green#05/02 12:00 park
BBB	Blue#04/22 15:00 home	Yellow#05/01 09:00 office	Orange#04/29 12:55 park	Green#05/01 19:00 home
CCC	Blue#05/02 15:02 home	Yellow#05/02 09:00 school	Orange#05/01 16:00 office	Green#04/22 11:59 park

I have a fixed number of columns, but the number of rows differ. In example 5 columns and 4 rows.

What I want to do in the first step is to sort by date and time so that I only have the latest observation for each row, in this example I would get 3 rows and 2 Columns.

AAA	Yellow#05/03 12:05 home
BBB	Green#05/01 19:00 home
CCC	Blue#05/02 15:02 home

If possible I would like to take this one step further and Split the data in the observation to be like below, 2 rows and 4 columns.

AAA	home	Yellow	05/03
BBB	home	Green	05/01
CCC	home	Blue	05/02

Since I do this kind of things with large numbers of data every day it would really save time to just have a button doing it for me in one go.

Very thankful for your help!

[mdmackillop]

Can you post a workbook with sample data. Go Advanced/Manage Attachments.

[Bob Phillips]

I would do it with Power Query, but why is BBB Green and not Yellow, both have a date of 05/01?

[Akire87]

Hi!
Have attached an example of the data.

The dates and time does not correlate with the colors. The AAA, BBB, CCC are people observing. The colors in this example is of cars. Date and time is when that certain color of car is observed, and then you have where the observation was done.

So I have a sample of observations, and I want to see the latest observations for each subject.

[Bob Phillips]

The dates and time does not correlate with the colors. The AAA, BBB, CCC are people observing. The colors in this example is of cars. Date and time is when that certain color of car is observed, and then you have where the observation was done.

I can see that, but as an example BBB is looking at a yellow car on 1st May in the office, and a green car on the same date at home. Which takes preference?

[Akire87]

I see what you mean.
It is the latest one when it comes to time as well.
the yellow car was observed at 9.00 (9am) and the green one at 19.00(7pm), and then the green one takes preference.

[Bob Phillips]

As I said, I would use Power Query. Here is the query script I used

let
Source = Excel.CurrentWorkbook(){[Name="Table2"]}[Content],
blue.AddColum = Table.AddColumn(Source, "BlueDate", each "2017/" & Text.Range([Blue],Text.PositionOf([Blue],"#")+1,11)),
blue.ToDate = Table.TransformColumnTypes(blue.AddColum,{{"BlueDate", type datetime}}),
yellow.AddColum = Table.AddColumn(blue.ToDate, "YellowDate", each "2017/"& Text.Range([Yellow],Text.PositionOf([Yellow],"#")+1,11)),
yellow.ToDate = Table.TransformColumnTypes(yellow.AddColum,{{"YellowDate", type datetime}}),
orange.AddColum = Table.AddColumn(yellow.ToDate, "OrangeDate", each "2017/" & Text.Range([Orange],Text.PositionOf([Orange],"#")+1,11)),
orange.ToDate = Table.TransformColumnTypes(orange.AddColum,{{"OrangeDate", type datetime}}),
green.AddColum = Table.AddColumn(orange.ToDate, "GreenDate", each "2017/" & Text.Range([Green],Text.PositionOf([Green],"#")+1,11)),
green.ToDate = Table.TransformColumnTypes(green.AddColum,{{"GreenDate", type datetime}}),
dates.Unpivot = Table.UnpivotOtherColumns(green.ToDate, {"Column1", "Blue", "Yellow", "Orange", "Green"}, "Attribute", "Value"),
colour.AddColumn = Table.AddColumn(dates.Unpivot, "Colour", each Text.Replace([Attribute], "Date","")),
dates.Max = Table.AddColumn(colour.AddColumn, "Latest Date", each GetMaxDate(colour.AddColumn,[Column1])),
attribute.OfMax = Table.AddColumn(dates.Max, "Attribute Max",
each if [Colour] = "Blue" then [Blue] else
if [Colour] = "Yellow" then [Yellow] else
if [Colour] = "Orange" then [Orange] else [Green]),
type.OfMax = Table.AddColumn(attribute.OfMax, "Location", each Text.Range([Attribute Max], Text.PositionOf([Attribute Max],":")+4, Text.Length([Attribute Max])-Text.PositionOf([Attribute Max],":")-4)),
date.OfMax = Table.AddColumn(type.OfMax, "Date", each Text.Range([Attribute Max], Text.PositionOf([Attribute Max],"#")+1, 5)),
dates.FindMax = Table.AddColumn(date.OfMax, "date.IsMax", each if [Value] = [Latest Date] then true else false),
dates.LimitToMax = Table.SelectRows(dates.FindMax, each ([date.IsMax] = true)),
Final.Layout = Table.RemoveColumns(dates.LimitToMax,{"Blue", "Yellow", "Orange", "Green", "Attribute", "Value", "Latest Date", "Attribute Max", "date.IsMax"})
in
Final.Layout

This uses another function query, which I called GetMaxDate

table as table, criteria as any) =>

try Table.Max(Table.SelectRows(table, each criteria=[Column1]),"Value")[Value] otherwise null

[Paul_Hossler]

If you want to stay with a VBA approach, try this. I think this is what you were asking about

Option Explicit

Sub LookAtData()
    Dim wsIn As Worksheet, wsOut As Worksheet
    Dim rIn As Range, rOut As Range, rOut1 As Range
    Dim aIn As Variant
    Dim iOut As Long, iRowIn As Long, iColIn As Long
    Dim n As Long
    Dim v As Variant
    
    Application.ScreenUpdating = False
    
    'save input
    Set wsIn = Worksheets("Blad 1")
    Set rIn = wsIn.Cells(1, 1).CurrentRegion
    'get rid of header row and 2 extra columns
    Set rIn = rIn.Cells(2, 1).Resize(rIn.Rows.Count - 1, 5)
    aIn = rIn.Value
    
    'remove existing Output
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("Output").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    'add new Output
    Worksheets.Add.Name = "Output"
    Set wsOut = ActiveSheet

    'move data
    iOut = 1
    
    wsOut.Cells(iOut, 1).Value = "Name"
    wsOut.Cells(iOut, 2).Value = "Location"
    wsOut.Cells(iOut, 3).Value = "Color"
    wsOut.Cells(iOut, 4).Value = "Date"
    
    iOut = iOut + 1
    
    'go down Input
    'skip headers
    For iRowIn = LBound(aIn) + 1 To UBound(aIn)
        For iColIn = 2 To 5
            'name
            wsOut.Cells(iOut, 1).Value = aIn(iRowIn, 1)
            
            'color
            n = InStr(aIn(iRowIn, iColIn), "#")
            wsOut.Cells(iOut, 3).Value = Left(aIn(iRowIn, iColIn), n - 1)
        
            'date
            aIn(iRowIn, iColIn) = Right(aIn(iRowIn, iColIn), Len(aIn(iRowIn, iColIn)) - n)
            v = Split(aIn(iRowIn, iColIn), " ")
            wsOut.Cells(iOut, 4).Value = DateValue(v(0)) & " " & TimeValue(v(1))
    
            'location
            wsOut.Cells(iOut, 2).Value = v(2)
            
            iOut = iOut + 1
        Next iColIn
    Next iRowIn
    
    
    'sort name ascending, date descending
    Set rOut = wsOut.Cells(1, 1).CurrentRegion
    Set rOut1 = rOut.Cells(2, 1).Resize(rOut.Rows.Count - 1, rOut.Columns.Count)
    With wsOut.Sort
        .SortFields.Clear
        .SortFields.Add Key:=rOut1.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=rOut1.Columns(4), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        .SetRange rOut
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    'only keep first name entry = newest data
    With rOut
        For iOut = 2 To .Rows.Count - 1
            If .Cells(iOut, 1).Value = .Cells(iOut + 1, 1).Value Then .Cells(iOut, 4).Value = True
        Next iOut
        
        On Error Resume Next
        rOut.Columns(4).SpecialCells(xlCellTypeConstants, xlLogical).EntireRow.Delete
        On Error GoTo 0
    
        rOut.EntireColumn.AutoFit
    End With
    Application.ScreenUpdating = True
    MsgBox "Done"
 

End Sub

[Akire87]

Thank you!
Will have to work a bit more with Power query since I never worked with that before.

The VBA query works perfectly! Thanks!