consolidate data that occurs close together in time

[System Error]

I have about 7 columns of data. The second one has about 150 different types
of components, about 2000 entries in all. the third column is the start date
im looking for, the fourth is the start time. Fifth is the end date, Sixth
is the end time. I am looking for a macro to go through each component,
check the next component to see if its the same one, if it is, check the end
date/time of the first one, and if it is within one day of the start time of
the next entry, combine the two entries and delete the old ones. What I have
so far is (This is kinda long, I apologize)
Sub Compare_Dates()
Dim CompRange As Range, CopyRange As Range
Dim There As Boolean, This As Boolean
Dim days As Date
Dim Hours As Double
There = False
LastRow1 = Sheets("Sheet1").Cells(Cells.Rows.Count, "A").End(xlUp).Row
Set CompRange = Sheets("Sheet1").Range("A2:A" & LastRow1)
For Each c In CompRange
If c.Value = c.Offset(1, 0).Value Then
There = True
End If
If There Then
days = c.Offset(0, 4).Value - c.Offset(1, 2).Value
Hours = c.Offset(0, 5).Value - c.Offset(1, 3).Value
If days + Hours <= 1 Then
c.Offset(1, 2) = c.Offset(0, 2).Value
c.Offset(1, 3) = c.Offset(0, 5).Value
'Need to check the date of c.offset(0,4) with c.offset(1,2)
'If they are within x days of each other
'c.offset(1,2).value=c.offset(0,2).value
Else
There = False
If There Then
If CopyRange Is Nothing Then
Set CopyRange = c.Offset(1, 0).EntireRow
Else
Set CopyRange = Union(CopyRange, c.Offset(1, 0).EntireRow)
End If
End If
'This If loop checks if the CopyRange currently has any rows
'If not, it places c in it
End If
End If

There = False
Next
If Not CopyRange Is Nothing Then
CopyRange.Delete
End If


End Sub

I think the only problem is comparing the dates, Other than that I feel like
it should work. Any help with this macro, or any ideas for a different macro
would be greatly appreciated!

Thanks in advance, sorry for the long post!!

 

[OssieMac]

Before spending a lot of time on this because you suspect the comparison of
the Dates/times.

Are the Hours entered as proper times on the worksheet. If so then dimension
the Hours variable as a date and see what happens.

Time in VBA are in fact dates. (Just a fraction of a day.) and the variables
should be dimensioned as dates.

 

[System Error]

Hmm... the hours are entered as proper time/format. For some reason it still
didnt to work. I got it to work in the end by just making a temporary column
in excel that had the data computed already. functionally works perfectly
now, just i wish it was fully automated. Thank you anyways for your time.

 

[OssieMac]

My apologies for not getting back to you sooner but I have been away.

I can follow your code and at this point I am not able to ascertain exactly
what the problem is without the real data. One thing you might consider is
assigning some of the date values to variables declared as double and place
stops in your code and then when the code stops, hover the cursor over the
double variables and see what they are returning. The following example of
code shows just what can occur as you manipulate dates in VBA due to rounding
of the nth decimal places and date/times that you think should be equal will
not compare as equal.

Sub testDateComparison()

Dim dateFromWs As Date
Dim dateFromStr As Date
Dim timeFromStr As Date
Dim dateCalculated As Date
Dim dblOrigDate As Double
Dim dblNewDate As Double

Dim strDate As String
Dim strTime As String

'Insert NOW() formula on worksheet
Worksheets("Sheet1").Cells(2, 1).Formula = "=Now()"

'Get date and time from the worksheet
dateFromWs = Worksheets("Sheet1").Cells(2, 1)

'Convert date and time to string format
strDate = Format(dateFromWs, "dd mm yyyy hh:mm:ss")

'Convert string format date portion back to date
dateFromStr = DateSerial(Year(strDate), Month(strDate), Day(strDate))

'Convert stringformat time portion back to date
timeFromStr = TimeSerial(Hour(strDate), Minute(strDate), Second(strDate))

'Sum the new date and time
dateCalculated = dateFromStr + timeFromStr

dblOrigDate = dateFromWs
dblNewDate = dateCalculated

'Compare the original date to the new date
'When converted to serial numbers both dates
'produce slightly different numbers.

MsgBox "Original date time as Serial = " & _
dblOrigDate & vbCrLf & _
"New date and time as Serial = " & _
dblNewDate & vbCrLf & _
"Original date time as date = " & _
dateFromWs & vbCrLf & _
"New date and time as date = " & _
dateCalculated

If dblOrigDate = dblNewDate Then
MsgBox "Dates match"
Else
MsgBox "Dates do not match"
End If

Stop
End Sub