Compare dates and times and delete rows

[maym]

Hi all

I have a spreadsheet that has 2 pieces of data - one of a actual date and time and the other latest date and time. I need to compare each record's time and keep the record that is closest between actual date and time and latest date and time. If the two match, then I need to keep the record that has the lowest value in Col G. I have attached a sample which hopefully explains.

Is there a way I can achieve this in VBA?

Thanks

[maym]

I should have explained further:

First I need to compare the time in Col E to the time in Col F for each record (each name in Col F is it's own record) and then find the times that are the closest match. I then need to keep that record and delete the others.

Second, if the closest time match has more than one record (as shown in sample), I need to keep the record that has the lowest value in Col G.

I am experimenting with comparing dates but I am having trouble with including records also.

Can anyone please assist with this?

[maym]

If anyone can please help me out, it would be really appreciated

[Arkadi]

In your example you say rows 1 and 2 are the same so you need to keep the lowest col G value... but rows 4-6 seem to be a match as well for all other columns, so I don't understand the criteria for matching.

Also, you say you want a comparison of time between columns E and F but the data in column F is not a time value.

[maym]

ok I should have explained further.

It is the time in Col E to compare to the time in Col H (not F).

In rows 2 and 3 in the sample, the time in Col E is the closest match to the time in Col H for all records for item 1 (AT) which has 5 records (rows 2-6). So in this case I need to keep the row that has the lowest value in Col G (which is row 2).

For the next record (item 2 - PN), the closest match in Col E to Col H is row 10 (it is an exact match), so I need to keep this row and delete the others.

For the next record (item 3 - NZ), the closest match in Col E to Col H is row 14 (it is only 1 second difference), so I need to keep this row and delete the others.

I hope this makes sense?

[scottiex]

So there are fractions of a second (or maybe just fractions of a minute) difference in the times that are not visible at first glance right?

[maym]

yes that is right. I have amended the format of the column of the columns now to be d/mm/yyyy h:mm:ss which shows the seconds difference (if any).

[maym]

Does anyone know of a way I can solve this problem please?

[Arkadi]

I'll have a go at this in a few minutes and reply here soon.

[Arkadi]

Ok, how about this:

Sub maym()

Dim ws As Worksheet
Dim lr As Long
Dim wholeRng As Range
Dim myRng As Range
Dim closeRng As Range
Dim myDifference As Long
Dim i As Long

Application.ScreenUpdating = False
Set ws = Worksheets("Sheet1") 'change sheet name as needed
lr = ws.Range("A" & Rows.Count).End(xlUp).Row 'find last row with data, based on col A in this case
Set wholeRng = ws.Range("A1:H" & lr)
For i = lr To 2 Step -1 'loop through rows with data, ending at 2 since 1 is headers
    wholeRng.AutoFilter field:=6, Criteria1:=ws.Range("F" & i).Value
    Set myRng = wholeRng.Rows("2:" & wholeRng.Rows.Count).SpecialCells(xlCellTypeVisible)
    Set closeRng = myRng.Rows(myRng.Rows.Count)
    myDifference = Abs(DateDiff("s", closeRng.Columns(8).Value, closeRng.Columns(5).Value))
    i = i - (myRng.Rows.Count - 1)
    For j = myRng.Rows.Count To 2 Step -1
        If Abs(DateDiff("s", myRng.Cells(j - 1, 8).Value, myRng.Cells(j - 1, 5).Value)) < _
        myDifference Then
            Set closeRng = myRng.Rows(j - 1)
            myDifference = Abs(DateDiff("s", closeRng.Columns(8).Value, closeRng.Columns(5).Value))
            myRng.Rows(j).EntireRow.Delete
        ElseIf Abs(DateDiff("s", myRng.Cells(j - 1, 8).Value, myRng.Cells(j - 1, 5).Value)) > _
        myDifference Then
            myRng.Rows(j - 1).EntireRow.Delete
        Else
            If myRng.Cells(j - 1, 7).Value < myRng.Cells(j, 7).Value Then
                myRng.Rows(j).EntireRow.Delete
            Else
                myRng.Rows(j - 1).EntireRow.Delete
            End If
        End If
    Next j
    ws.AutoFilterMode = False
Next i
Application.ScreenUpdating = True

End Sub

[maym]

this is perfect Arkadi, thanks!

The only thing is, I have over 150,000 rows in my sheet and I need to run this frequently. Unfortunately it took over 15 mins

Is there a way to speed it up?

Also, some cells in Col E will be blank. In this case, I need to keep the row that has the lowest value in Col G. Can your code be adjusted to reflect this?

[maym]

great! Thank you so much Arkadi

[maym]

I wonder if it is possible to speed this macro up to account for my large worksheet??

[Marc L]

Hi !

Yes like in that thread 'cause using SpecialCells and Delete is slow …

[Arkadi]

Maym... Ill be looking at it today

[maym]

Could anyone please assist me with this problem?

[Arkadi]

maym, sorry, weekend got too busy with Mother's day stuff, but I'll try another approach soon...

[Arkadi]

Give this one a try, should be faster...

Sub maym()

'this assumes data is already sorted based on the values in Col. F

Dim ws As Worksheet
Dim lr As Long
Dim wholeRng As Range
Dim myRng As Range
Dim closeRng As Range
Dim myDifference As Long
Dim i As Long

Application.ScreenUpdating = False
Set ws = Worksheets("Sheet1") 'change sheet name as needed
lr = ws.Range("A" & Rows.Count).End(xlUp).Row 'find last row with data, based on col A in this case
Set wholeRng = ws.Range("A1:H" & lr)

For i = lr To 2 Step -1 'loop through rows with data, ending at 2 since 1 is headers
    If ws.Range("F" & i).Value = ws.Range("F" & i - 1).Value Then 'this only compares F column to see if records are the same, and AND statements if more columns need to be compared
        myDifference = Abs(DateDiff("s", ws.Range("H" & i).Value, ws.Range("E" & i).Value))
        If Abs(DateDiff("s", ws.Range("H" & i - 1).Value, ws.Range("E" & i - 1).Value)) < myDifference Then
            myDifference = Abs(DateDiff("s", ws.Range("H" & i - 1).Value, ws.Range("E" & i - 1).Value))
            ws.Rows(i).EntireRow.Delete
        ElseIf Abs(DateDiff("s", ws.Range("H" & i - 1).Value, ws.Range("E" & i - 1).Value)) > myDifference Then
            ws.Rows(i - 1).EntireRow.Delete
        Else 'in this case the time difference is the same
            If ws.Range("G" & i).Value < ws.Range("G" & i - 1).Value Then
                ws.Rows(i - 1).EntireRow.Delete
            Else
                ws.Rows(i).EntireRow.Delete
            End If
        End If
    End If
Next i
Application.ScreenUpdating = True

End Sub

[maym]

thank you Arkadi I ran it, it took 427 secs which is better than it was.

Also, some cells in Col E will be blank. In this case I need to just keep the row (I had to delete them in order for your code to run). Is it possible to amend the code to account for this?

Thanks

[maym]

I am hoping there is someone who can assist me with this problem?

[jindon]

Check this

Sub test()
    Dim a, i As Long, ii As Long, w, dif As Double
    With Sheets("sheet1").Cells(1).CurrentRegion
        a = .Value ':.clearcontents
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 2 To UBound(a, 1)
                dif = Round(Abs(CDbl(a(i, 8)) - CDbl(a(i, 5))), 5)
                If Not .exists(a(i, 6)) Then
                    .Item(a(i, 6)) = Array(.Count + 2, dif)
                    For ii = 1 To UBound(a, 2)
                        a(.Count + 1, ii) = a(i, ii)
                    Next
                Else
                    If (.Item(a(i, 6))(1) > dif) + _
                       ((.Item(a(i, 6))(1) = dif) * (a(.Item(a(i, 6))(0), 7) > a(i, 7))) Then
                        For ii = 1 To UBound(a, 2)
                            a(.Item(a(i, 6))(0), ii) = a(i, ii)
                        Next
                    End If
                End If
            Next
            i = .Count + 1
        End With
    End With
    With Sheets.Add.Cells(1).Resize(i, UBound(a, 2))
        .Value = a: .Columns.AutoFit
    End With
End Sub

[maym]

thank you jindon, that works great

However, could the data appear on the same sheet (sheet 1)? At the moment it adds another sheet but I don't need this.

Thanks

[maym]

thank you jindon. Could this code be adjusted to account for the values labelled "TBC" as outlined in my previous post?

[maym]

also, Col D sometimes has a value labelled "TBC". If this is the case, I need to keep all of these rows (and run the macro above on all the others). Is there a way the macro can be adjusted to achieve this?

Thanks again.

[jindon]

Change to

Sub test()
    Dim a, i As Long, ii As Long, w, dif As Double
    With Sheets("sheet1").Cells(1).CurrentRegion
        a = .Value: .ClearContents
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 2 To UBound(a, 1)
                dif = Round(Abs(CDbl(a(i, 8)) - CDbl(a(i, 5))), 5)
                If Not .exists(a(i, 6)) Then
                    .Item(a(i, 6)) = Array(.Count + 2, dif)
                    For ii = 1 To UBound(a, 2)
                        a(.Count + 1, ii) = a(i, ii)
                    Next
                Else
                    If (.Item(a(i, 6))(1) > dif) + _
                       ((.Item(a(i, 6))(1) = dif) * (a(.Item(a(i, 6))(0), 7) > a(i, 7))) Then
                        For ii = 1 To UBound(a, 2)
                            a(.Item(a(i, 6))(0), ii) = a(i, ii)
                        Next
                    End If
                End If
            Next
            i = .Count + 1
        End With
        .Resize(i).Value = a
    End With
End Sub

[maym]

thank you jindon, that is great

It is almost there. For those rows that have a value of "TBC" in Col D, I need to keep the row that has the largest value in Col H only. E.g. the values could be as follows:

25/05/2016 3:45:02
25/05/2016 3:45:12
25/05/2016 3:45:01
25/05/2016 3:45:07

In this case I only need to keep the row with the 3:45:12 value as it is the largest.

Can the code be adjusted to reflect this?

Thanks again.

[jindon]

thank you jindon, that is great

It is almost there. For those rows that have a value of "TBC" in Col D, I need to keep the row that has the largest value in Col H only. E.g. the values could be as follows:

25/05/2016 3:45:02
25/05/2016 3:45:12
25/05/2016 3:45:01
25/05/2016 3:45:07

In this case I only need to keep the row with the 3:45:12 value as it is the largest.

Can the code be adjusted to reflect this?

Thanks again.

Can you explain the logic completely?
This means when col.D is "TBC", it deletes all the rows but the largest in col.H?

[maym]

I ran it on the sample sheet jindon and it deleted all but one record. So unfortunately it still is deleting too many records and not leaving the correct ones?

[jindon]

I didn't see that post...

Sub test()
    Dim a, i As Long, ii As Long, w, dif As Double, n As Long
    With Sheets("sheet1").Cells(1).CurrentRegion
        a = .Value: .ClearContents: n = 1
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 2 To UBound(a, 1)
                dif = Round(Abs(CDbl(a(i, 8)) - CDbl(a(i, 5))), 5)
                If a(i, 4) = "TBC" Then
                    n = n + 1
                    For ii = 1 To UBound(a, 2)
                        a(n, ii) = a(i, ii)
                    Next
                Else
                    If Not .exists(a(i, 6)) Then
                        n = n + 1
                        .Item(a(i, 6)) = Array(n, dif)
                        For ii = 1 To UBound(a, 2)
                            a(n, ii) = a(i, ii)
                        Next
                    Else
                        If (.Item(a(i, 6))(1) > dif) + _
                           ((.Item(a(i, 6))(1) = dif) * (a(.Item(a(i, 6))(0), 7) > a(i, 7))) Then
                            For ii = 1 To UBound(a, 2)
                                a(.Item(a(i, 6))(0), ii) = a(i, ii)
                            Next
                        End If
                    End If
                End If
            Next
        End With
        .Resize(n).Value = a
    End With
End Sub

[maym]

Thanks jindon, but it appears to be deleting all of the rows now with "TBC" in them?

[jindon]

Change to

Sub test()
    Dim a, i As Long, dif As Double, n As Long, flg As Boolean, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    With Sheets("sheet1").Cells(1).CurrentRegion
        a = .Value: .ClearContents: n = 2
        For i = 2 To UBound(a, 1)
            flg = a(i, 4) <> "TBC"
            If Not flg Then
                dif = a(i, 7)
            Else
                dif = Round(Abs(CDbl(a(i, 8)) - CDbl(a(i, 5))), 5)
            End If
            CheckData a, dic, i, n, dif, flg
        Next
        .Resize(n).Value = a
    End With
End Sub

Private Sub CheckData(a, dic As Object, i As Long, n As Long, dif As Double, flg As Boolean)
    Dim ii As Long
    If flg Then
        If Not dic.exists(a(i, 6)) Then
            n = n + 1: dic(a(i, 6)) = Array(n, dif)
            For ii = 1 To UBound(a, 2)
                a(n, ii) = a(i, ii)
            Next
        Else
            If (dic(a(i, 6))(1) > dif) + _
               ((dic(a(i, 6))(1) = dif) * (a(dic(a(i, 6))(0), 7) > a(i, 7))) Then
                For ii = 1 To UBound(a, 2)
                    a(dic(a(i, 6))(0), ii) = a(i, ii)
                Next
            End If
        End If
    Else
        If Not dic.exists(a(i, 4)) Then
            n = n + 1: dic(a(i, 4)) = Array(n, dif)
            For ii = 1 To UBound(a, 2)
                a(n, ii) = a(i, ii)
            Next
        Else
            If dif > dic(a(i, 4))(1) Then
                For ii = 1 To UBound(a, 2)
                    a(dic(a(i, 4))(0), ii) = a(i, ii)
                Next
            End If
        End If
    End If
End Sub

[maym]

yes it has left one line in total, but it should leave one line for each record that has "TBC" in the value?

[jindon]

It leaves one line which have "TBC" in Col.D.

[maym]

here is a sample so that you can see what is happening. It should delete each of the "TBC" rows but it only leaves one or two??

[maym]

what I meant to say is that it should delete each record that isn't the largest value in Col H, so I have sorted the workbook and you will see for the first record, it should delete a number of rows and leave one, but it doesn't appear to be doing this?

[maym]

yes that is correct. It will delete all the rows for each record, except for the largest in Col H. So in the attached sample, 1. Abo is one record. It should delete all the values except for row 7 (so rows 2 -6 and rows 8-24 to be deleted). 1. Bea is another record, so it should delete all the values except for row 27 (so rows 25-26 and row 28 to be deleted) and so on. I hope this makes sense?

[jindon]

OK, I think the reference was wrong.

Sub test()
    Dim a, i As Long, dif As Double, n As Long, flg As Boolean, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    With Sheets("sheet1").Cells(1).CurrentRegion
        a = .Value: .ClearContents: n = 1
        For i = 2 To UBound(a, 1)
            flg = a(i, 4) <> "TBC"
            If Not flg Then
                dif = Round(CDbl(a(i, 8)), 5)
            Else
                dif = Round(Abs(CDbl(a(i, 8)) - CDbl(a(i, 5))), 5)
            End If
            CheckData a, dic, i, n, dif, flg
        Next
        .Resize(n).Value = a
    End With
End Sub

Private Sub CheckData(a, dic As Object, i As Long, n As Long, dif As Double, flg As Boolean)
    Dim ii As Long, w
    If flg Then
        If Not dic.exists(a(i, 6)) Then
            n = n + 1: dic(a(i, 6)) = Array(n, dif, a(i, 7))
            For ii = 1 To UBound(a, 2)
                a(n, ii) = a(i, ii)
            Next
        Else
            w = dic(a(i, 6))
            If (w(1) > dif) + _
               ((w(1) = dif) * (w(2) > a(i, 7))) Then
                For ii = 1 To UBound(a, 2)
                    a(w(0), ii) = a(i, ii)
                Next
                w(1) = dif: w(2) = a(i, 7): dic(a(i, 6)) = w
            End If
        End If
    Else
        If Not dic.exists(a(i, 4)) Then
            n = n + 1: dic(a(i, 4)) = Array(n, dif)
            For ii = 1 To UBound(a, 2)
                a(n, ii) = a(i, ii)
            Next
        Else
            w = dic(a(i, 4))
            If dif >= w(1) Then
                For ii = 1 To UBound(a, 2)
                    a(w(0), ii) = a(i, ii)
                Next
                w(1) = dif: dic(a(i, 4)) = w
            End If
        End If
    End If
End Sub

[jindon]

That's why I asked.

This means when col.D is "TBC", it deletes all the rows but the largest in col.H?

[maym]

yes but if you see the sample sheet, you will see what I mean. The code deletes ALL ROWS, where it should only be deleting rows but leaving each record with the largest value. I have manually put the first few records in sheet 2 to show you what I mean.

[jindon]

That means not ALL. Delete only non highest in same "se" col.F....
Test this hard.

Sub test()
    Dim a, i As Long, dif As Double, n As Long, flg As Boolean, dic As Object, TBC As Object
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    Set TBC = CreateObject("Scripting.Dictionary")
    With Sheets("sheet1").Cells(1).CurrentRegion
        a = .Value: .ClearContents: n = 1
        For i = 2 To UBound(a, 1)
            flg = a(i, 4) <> "TBC"
            If Not flg Then
                dif = Round(CDbl(a(i, 8)), 5)
            Else
                dif = Round(Abs(CDbl(a(i, 8)) - CDbl(a(i, 5))), 5)
            End If
            'MsgBox TBC.Count
            CheckData a, IIf(flg, dic, TBC), i, n, dif, flg
        Next
        .Resize(n).Value = a
    End With
End Sub

Private Sub CheckData(a, dic As Object, i As Long, n As Long, dif As Double, flg As Boolean)
    Dim ii As Long, w
    If flg Then
        If Not dic.exists(a(i, 6)) Then
            n = n + 1: dic(a(i, 6)) = Array(n, dif, a(i, 7))
            For ii = 1 To UBound(a, 2)
                a(n, ii) = a(i, ii)
            Next
        Else
            w = dic(a(i, 6))
            If (w(1) > dif) + _
               ((w(1) = dif) * (w(2) > a(i, 7))) Then
                For ii = 1 To UBound(a, 2)
                    a(w(0), ii) = a(i, ii)
                Next
                w(1) = dif: w(2) = a(i, 7): dic(a(i, 6)) = w
            End If
        End If
    Else
        If Not dic.exists(a(i, 6)) Then
            n = n + 1: dic(a(i, 6)) = Array(n, dif)
            For ii = 1 To UBound(a, 2)
                a(n, ii) = a(i, ii)
            Next
        Else
            w = dic(a(i, 6))
            If dif >= w(1) Then
                For ii = 1 To UBound(a, 2)
                    a(w(0), ii) = a(i, ii)
                Next
                w(1) = dif: dic(a(i, 6)) = w
            End If
        End If
    End If
End Sub

[maym]

That means not ALL. Delete only non highest in same "se" col.F....
Test this hard.

Sub test()
    Dim a, i As Long, dif As Double, n As Long, flg As Boolean, dic As Object, TBC As Object
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    Set TBC = CreateObject("Scripting.Dictionary")
    With Sheets("sheet1").Cells(1).CurrentRegion
        a = .Value: .ClearContents: n = 1
        For i = 2 To UBound(a, 1)
            flg = a(i, 4) <> "TBC"
            If Not flg Then
                dif = Round(CDbl(a(i, 8)), 5)
            Else
                dif = Round(Abs(CDbl(a(i, 8)) - CDbl(a(i, 5))), 5)
            End If
            'MsgBox TBC.Count
            CheckData a, IIf(flg, dic, TBC), i, n, dif, flg
        Next
        .Resize(n).Value = a
    End With
End Sub

Private Sub CheckData(a, dic As Object, i As Long, n As Long, dif As Double, flg As Boolean)
    Dim ii As Long, w
    If flg Then
        If Not dic.exists(a(i, 6)) Then
            n = n + 1: dic(a(i, 6)) = Array(n, dif, a(i, 7))
            For ii = 1 To UBound(a, 2)
                a(n, ii) = a(i, ii)
            Next
        Else
            w = dic(a(i, 6))
            If (w(1) > dif) + _
               ((w(1) = dif) * (w(2) > a(i, 7))) Then
                For ii = 1 To UBound(a, 2)
                    a(w(0), ii) = a(i, ii)
                Next
                w(1) = dif: w(2) = a(i, 7): dic(a(i, 6)) = w
            End If
        End If
    Else
        If Not dic.exists(a(i, 6)) Then
            n = n + 1: dic(a(i, 6)) = Array(n, dif)
            For ii = 1 To UBound(a, 2)
                a(n, ii) = a(i, ii)
            Next
        Else
            w = dic(a(i, 6))
            If dif >= w(1) Then
                For ii = 1 To UBound(a, 2)
                    a(w(0), ii) = a(i, ii)
                Next
                w(1) = dif: dic(a(i, 6)) = w
            End If
        End If
    End If
End Sub

sorry to bring up an old thread, but I have an added complexity to solve for now with this.

If there is no actual value in col E, i.e. column is blank, how can I amend the macro above to account for this? Everything works fine and has done so but now the report I receive can often leave this column blank. When it does, the macro completely removes all the data.

[maym]

thanks jindon, I wasn't explaining it correctly then. This looks great. I will check further tomorrow when I have some more time

[jindon]

Just inform you that, I forgot to delete the msgbox lines for my testing use.

If you have trouble, Hit Ctrl + Break to get into debug mode.

Code has been edited.

[maym]

thank you jindon, that works perfectly

I almost have it, there is just one other piece that I am trying to solve for. This is a little different so I am not sure if I can post within this thread or if I need to start another.

When the value is "TBC" in Col D, I need to check to see if the value in Col G is repeated, and if it is, I need to copy the value in Col D to that row. I have inputted these into a new Col (E) in the sample sheet to show you what I mean. This would be repeated all the way down, but I'm not sure how I could go about achieving this?

[maym]

I should also add that in the sample sheet, the data appears in the very next row, but this may not always be the case with the real data.

[jindon]

Like this?

Sub MatchD()
    With Range("d2", Range("d" & Rows.Count).End(xlUp))
        a = .Resize(, 4).Value
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 1 To UBound(a, 1)
                If a(i, 1) <> "TBC" Then
                    .Item(a(i, 4)) = a(i, 1)
                Else
                    a(i, 1) = .Item(a(i, 4))
                End If
            Next
        End With
        .Value = a
    End With
End Sub

[maym]

yes! That is great jindon, thank you!

If I wanted to put the value in Col E (rather than replace the value in Col D) how can I adjust the code to do this?

[jindon]

Change 2 lines

Sub MatchD()
    With Range("d2", Range("d" & Rows.Count).End(xlUp)).Resize(, 2)
        a = .Resize(, 4).Value
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 1 To UBound(a, 1)
                If a(i, 1) <> "TBC" Then
                    .Item(a(i, 4)) = a(i, 1)
                Else
                    a(i, 2) = .Item(a(i, 4))
                End If
            Next
        End With
        .Value = a
    End With
End Sub

[maym]

perfect! Thank you so much!!

[jindon]

If that takes care of your original question, please select Thread Tools from the menu link above and mark this thread as SOLVED.

[maym]

Some rows are blank, and I am trying to put the value in Col A into them.

[maym]

I am trying to do the same thing on Col A but it is not working. I am using the following:

Sub MatchA()
    With Range("a2", Range("a" & Rows.Count).End(xlUp))
        a = .Resize(, 1).Value
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 1 To UBound(a, 1)
                If a(i, 1) <> "" Then
                    .Item(a(i, 1)) = a(i, 1)
                Else
                    a(i, 1) = .Item(a(i, 1))
                End If
            Next
        End With
        .Value = a
    End With
End Sub

Can you please assist me with this?

[jindon]

Don't understand what you are trying to do from you code.

Need to see your workbook with before/after.

[maym]

ok I will explain further. In the attached workbook, I have shown what it looks like with example 1 before and after. This is how it currently works and it works fine. It compares times in Col E and ColF then takes the smallest value in Col G for the series.

In example 2, I don't have times in Col E, so I have shown what it should look like in Example 2 After sheet.

However the macro (when there is no data in Col E) gives me the 'type mismatch' error on this line:

dif = Round(Abs(CDbl(a(I, 8)) - CDbl(a(I, 5))), 5)

[jindon]

So what is the logic to find the data to leave with col.E has no data?

[maym]

well, when Col E has no data, the macro should find the latest date and time in Col H, keep this record and delete the others.

The macro above will compare the dates and times between Col E and Col H and keep the lowest, but in the absence of no data in Col E, I don't think it works properly.

I have updated the sample sheet to show what the correct output should be for example 2. If the latest date and time is the same for 2 records, it should keep the record with the lowest of the value in Col G (this is the case for the last 2 records).

[jindon]

I think I'm confused.

Is this related to your original question?
I mean should all the other conditions be taken in account?

[maym]

yes, it is related as this was the original question (to compare the dates and times and keep only the rows that had the latest values) and the macro you provided me does this:

Sub test()
    Dim a, i As Long, dif As Double, n As Long, flg As Boolean, dic As Object, TBC As Object
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    Set TBC = CreateObject("Scripting.Dictionary")
    With Sheets("sheet1").Cells(1).CurrentRegion
        a = .Value: .ClearContents: n = 1
        For i = 2 To UBound(a, 1)
            flg = a(i, 4) <> "TBC"
            If Not flg Then
                dif = Round(CDbl(a(i, 8)), 5)
            Else
                dif = Round(Abs(CDbl(a(i, 8)) - CDbl(a(i, 5))), 5)
            End If
            'MsgBox TBC.Count
            CheckData a, IIf(flg, dic, TBC), i, n, dif, flg
        Next
        .Resize(n).Value = a
    End With
End Sub

Private Sub CheckData(a, dic As Object, i As Long, n As Long, dif As Double, flg As Boolean)
    Dim ii As Long, w
    If flg Then
        If Not dic.exists(a(i, 6)) Then
            n = n + 1: dic(a(i, 6)) = Array(n, dif, a(i, 7))
            For ii = 1 To UBound(a, 2)
                a(n, ii) = a(i, ii)
            Next
        Else
            w = dic(a(i, 6))
            If (w(1) > dif) + _
               ((w(1) = dif) * (w(2) > a(i, 7))) Then
                For ii = 1 To UBound(a, 2)
                    a(w(0), ii) = a(i, ii)
                Next
                w(1) = dif: w(2) = a(i, 7): dic(a(i, 6)) = w
            End If
        End If
    Else
        If Not dic.exists(a(i, 6)) Then
            n = n + 1: dic(a(i, 6)) = Array(n, dif)
            For ii = 1 To UBound(a, 2)
                a(n, ii) = a(i, ii)
            Next
        Else
            w = dic(a(i, 6))
            If dif >= w(1) Then
                For ii = 1 To UBound(a, 2)
                    a(w(0), ii) = a(i, ii)
                Next
                w(1) = dif: dic(a(i, 6)) = w
            End If
        End If
    End If
End Sub

So now, keeping everything the same, if there is no values in Col E, I need to check for the latest value in Col H and keep these records. If the same date and time exists across more than one record, I need to keep the lowest value in Col G.

[maym]

thank you jindon. When you say the result is different, do you mean to the original solution you provided?

[maym]

I believe it is to do with these lines:

 dif = Round(CDbl(a(i, 8)), 5)
            Else
                dif = Round(Abs(CDbl(a(i, 8)) - CDbl(a(i, 5))), 5)

As there is nothing in Col E, I am trying to amend the macro to say that there is no data in Col E so proceed with the rest but I just can't seem to get it?

[jindon]

I think I understand the logic, but the result is different.

Sub test()
    Dim a, i As Long, dif, n As Long, flg As Boolean, dic As Object, TBC As Object
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    Set TBC = CreateObject("Scripting.Dictionary")
    a = Sheets("Example 2 Before").Cells(1).CurrentRegion.Value: n = 1
    For i = 2 To UBound(a, 1)
        flg = a(i, 4) <> "TBC"
        If Not flg Then
            dif = Round(CDbl(a(i, 8)), 5)
        Else
            If a(i, 5) = Empty Then
                dif = a(i, 8)
            Else
                dif = Round(Abs(CDbl(a(i, 8)) - CDbl(a(i, 5))), 5)
            End If
        End If
        CheckData a, IIf(flg, dic, TBC), i, n, dif, flg
    Next
    Sheets.Add.Cells(1).Resize(n, UBound(a, 2)).Value = a
End Sub

Private Sub CheckData(a, dic As Object, i As Long, n As Long, dif, flg As Boolean)
    Dim ii As Long, w, flg1 As Boolean
    If flg Then
        If Not dic.exists(a(i, 6)) Then
            n = n + 1: dic(a(i, 6)) = Array(n, dif, a(i, 7))
            For ii = 1 To UBound(a, 2)
                a(n, ii) = a(i, ii)
            Next
        Else
            w = dic(a(i, 6))
            If IsDate(w(1)) Then
                flg1 = w(1) < dif + ((w(1) = dif) * (w(2) > a(i, 7)))
            Else
                flg1 = (w(1) > dif) + ((w(1) = dif) * (w(2) > a(i, 7)))
            End If
            If flg1 Then
                For ii = 1 To UBound(a, 2)
                    a(w(0), ii) = a(i, ii)
                Next
                w(1) = dif: w(2) = a(i, 7): dic(a(i, 6)) = w
            End If
        End If
    Else
        If Not dic.exists(a(i, 6)) Then
            n = n + 1: dic(a(i, 6)) = Array(n, dif)
            For ii = 1 To UBound(a, 2)
                a(n, ii) = a(i, ii)
            Next
        Else
            w = dic(a(i, 6))
            If dif >= w(1) Then
                For ii = 1 To UBound(a, 2)
                    a(w(0), ii) = a(i, ii)
                Next
                w(1) = dif: dic(a(i, 6)) = w
            End If
        End If
    End If
End Sub

[jindon]

No, different from your after sheet, I mean.

[maym]

yours is actually capturing the correct data. In my after sheet. I did not have the latest values for some

[jindon]

If that takes care of your original question, please select Thread Tools from the menu link above and mark this thread as SOLVED.

[maym]

see attached sample taken from my 'real' data. The type mismatch error occurs here.

Could you please take a look for me?

The only thing I can think of is the date and time (perhaps because it is shown in a different format)?

[maym]

Hi

I now get 'type mismatch' error on this line

flg1 = w(1) < dif + ((w(1) = dif) * (w(2) > a(i, 7)))

[jindon]

No error and if you are testing with other data, no idea.

[jindon]

Col.H is just a text not date.

[maym]

ok so if Col H is not a date but text, how can I adjust the code to account for both date and text?

[maym]

In this sample you mean? Or the other sample that I provided?

Is there a way I can account for both formats in your code?

[jindon]

Why only text in this workbook?

If it is mixed, almost impossible to read if it is a real date or not.

dd/mm/yyyy or mm/dd/yyyy for data like 2/3/2017, 5/4/2017 etc.

[jindon]

If it is as date, should have no error.

Col H in your latest file is not a date.

[maym]

also the macro outputs to a new sheet - is there a way it can overwrite the current data in sheet 1?

[jindon]

replace "test" sub with

Sub test()
    Dim a, i As Long, dif, n As Long, flg As Boolean, dic As Object, TBC As Object
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    Set TBC = CreateObject("Scripting.Dictionary")
    With Sheets("Example 2 Before").Cells(1).CurrentRegion
        a = .Value: n = 1
        For i = 2 To UBound(a, 1)
            flg = a(i, 4) <> "TBC"
            If Not flg Then
                dif = Round(CDbl(a(i, 8)), 5)
            Else
                If a(i, 5) = Empty Then
                    dif = a(i, 8)
                Else
                    dif = Round(Abs(CDbl(a(i, 8)) - CDbl(a(i, 5))), 5)
                End If
            End If
            CheckData a, IIf(flg, dic, TBC), i, n, dif, flg
        Next
        .ClearContents
        .Resize(n).Value = a
    End With
End Sub

But what is the meaning of this, when the code doesn't work?

[maym]

I get an error every time on this line:

flg1 = w(1) < dif + ((w(1) = dif) * (w(2) > a(i, 7)))

[jindon]

As I said, if Col.H is not date, no way, so please stop this.

[maym]

sorry, wasn't clear enough. This is with date in Col H.

Please see attached and you will see the error.

[maym]

I have just seen some of the dates are text. Sorry, will keep looking into it.