fill in Date and time where missing on 3 minute interval.

[Albert_A]

Hi

I am having trouble getting a VBA code to do the following:

2012/05/01 00:00:00
2012/05/01 00:03:00
2012/05/01 00:06:00
2012/05/01 00:15:00
2012/05/01 00:18:00

From this above to this below

2012/05/01 00:00:00
2012/05/01 00:03:00
2012/05/01 00:06:00
2012/05/01 00:09:00
2012/05/01 00:12:00
2012/05/01 00:15:00
2012/05/01 00:18:00

There are data entries next to these time stamps. I am able to create just the time stamps starting at the beginning and ending at the end of the month but I need it to fill in missing entries in a data set. The code below works but only some of the time. I have tried a few different things but nothing works.

Sub Insert_missing_3min()
'Inserts a row with the date and time where the missing date and time stamp is and a zero next to the date added.


    Dim min3 As Date
    Dim CurTime As Date
    Dim CurCell As Date
    Dim NextCell As Date
    
    
        
        
    min3 = 3 / 24 / 60
        
    If (Hour(ActiveCell) <> 0 Or Minute(ActiveCell) <> 0 Or Day(ActiveCell) <> 1) Then      'makes the start date the fisrt of the month at 00:00
      ActiveCell.EntireRow.Insert
      ActiveCell.Value = Year(ActiveCell.Offset(1, 0)) & "/" & Month(ActiveCell.Offset(1, 0)) & "/" & "16"
                      
    End If
    
    Maand = Month(ActiveCell)
    
   Do While IsDate(ActiveCell) And Month(ActiveCell) = Maand
   
            CurTime = DateValue(ActiveCell) + TimeValue(ActiveCell)
            CurCell = TimeValue(ActiveCell)
            NextCell = DateValue(ActiveCell.Offset(1, 0)) + TimeValue(ActiveCell.Offset(1, 0))
            
                        
            If (NextCell <> (CurCell + min3)) Then
                ActiveCell.Offset(1).EntireRow.Insert
                ActiveCell.Offset(1, 0).Activate
                ActiveCell.Value = CurTime + min3    '3 min time value in excell
                ActiveCell.Offset(0, 1).Value = 0                     ' Value in colum next to date 0
                With Selection.Interior                                 ' Highlight
                    .Pattern = xlSolid
                    .PatternColorIndex = xlAutomatic
                    .Color = 65535
                    .TintAndShade = 0
                    .PatternTintAndShade = 0
                End With
            Else
                ActiveCell.Offset(1, 0).Activate
            End If
    Loop


End Sub

Thank you

 

[Albert_A]

I am using windows XP and Excel 2007

Thank you