Oops,
Forgot about the doubled dates...
Sub test()
Dim lLastRow As Long
Dim lCurrRow As Long
Dim vValue As Variant
Application.ScreenUpdating = False
With Worksheets("Sheet1")
lLastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
For lCurrRow = lLastRow To 2 Step -1
If IsDate(Cells(lCurrRow - 1, 2).Value) And _
IsDate(Cells(lCurrRow, 2).Value) Then
If Cells(lCurrRow - 1, 2).Value < Cells(lCurrRow, 2).Value - 1 And _
Cells(lCurrRow - 1, 2).Value < Cells(lCurrRow, 2).Value Then
Cells(lCurrRow, 2).EntireRow.Insert
Cells(lCurrRow, 2).Value = Cells(lCurrRow + 1, 2).Value - 1
Cells(lCurrRow, 1).Value = Cells(lCurrRow + 1, 1).Value
lCurrRow = lCurrRow + 1
End If
End If
Next lCurrRow
End With
Application.ScreenUpdating = True
End Sub
HTH,
Bernie
MS Excel MVP
"Bernie Deitrick" <deitbe @ consumer dot org wrote in message
...
Try the macro below.
HTH,
Bernie
MS Excel MVP
Sub test()
Dim lLastRow As Long
Dim lCurrRow As Long
Dim vValue As Variant
Application.ScreenUpdating = False
With Worksheets("Sheet1")
lLastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
For lCurrRow = lLastRow To 2 Step -1
If IsDate(Cells(lCurrRow - 1, 2).Value) And _
IsDate(Cells(lCurrRow, 2).Value) Then
If Cells(lCurrRow - 1, 2).Value < Cells(lCurrRow, 2).Value - 1 Then
Cells(lCurrRow, 2).EntireRow.Insert
Cells(lCurrRow, 2).Value = Cells(lCurrRow + 1, 2).Value - 1
Cells(lCurrRow, 1).Value = Cells(lCurrRow + 1, 1).Value
lCurrRow = lCurrRow + 1
End If
End If
Next lCurrRow
End With
Application.ScreenUpdating = True
End Sub
"mhax" wrote in message
...
I've been working on the code i received yesterday!
That's what i have right now!
U 442 2006-01-01 10:00:00 1
U 442 2006-01-04 16:00:00 1 2
U 442 2006-01-07 07:00:00 0
U 442 2006-01-07 22:00:00 1
U 442 2006-01-07 13:00:00 0
That's what i want!
U 442 2006-01-01 10:00:00 1
U 442 2006-01-04 16:00:00 1 2
U 442 2006-01-05
U 442 2006-01-06
U 442 2006-01-07 07:00:00 0
U 442 2006-01-07 22:00:00 1
U 442 2006-01-07 13:00:00 0
That's the code i'm using!
Sub test()
Dim lLastRow As Long
Dim lCurrRow As Long
Dim vValue As Variant
Application.ScreenUpdating = False
With Worksheets("Sheet1")
lLastRow = .Cells(.Rows.Count, 2).End(xlUp)
For lCurrRow = lLastRow To 1 Step -1
vValue = .Cells(lCurrRow, 7).Value
If Len(vValue) 0 And IsNumeric(vValue) Then
Cells(lCurrRow, 1).Resize(vValue, _
1).EntireRow.Insert shift:=xlUp
Cells(lCurrRow, 6).Resize(vValue, _
1).Value = 1440
Cells(lCurrRow, 1).Resize(vValue, _
1).Value = .Cells(lCurrRow - 1, 1)
Cells(lCurrRow, 2).Resize(vValue, _
1).Value = .Cells(lCurrRow - 1, 2) + 1
End If
Next lCurrRow
End With
Application.ScreenUpdating = True
End Sub
I cant find how make the new insert line go under, and i cant find how
make the new dates fills up new blank cells! Need help! thanks!
--
mhax
------------------------------------------------------------------------
mhax's Profile: http://www.excelforum.com/member.php...o&userid=36450
View this thread: http://www.excelforum.com/showthread...hreadid=563411