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!