dates are missing

Hi. Anyone know a good strategy for filling in missing dates in a column of dates? I have a column of dates (and an adjacent column with 1 in each corresponding row). I want to insert all the missing dates and add 0 in the adjacent cell (the same column where the ones are). Anyone know a good way to do this?

Thanks. target123.csv
onyourmarkAsked:
Who is Participating?
 
NorieVBA ExpertCommented:
Probably not quite what you want but this will create a list with all the dates and put a 1 next to the those in the original list and a 0 next to the new dates.
Option Explicit

Sub DateList()
Dim dtStart As Date
Dim dtEnd As Date
Dim NoDays As Long

    dtStart = Range("A2")
    dtEnd = Range("A" & Rows.Count).End(xlUp)

    NoDays = dtEnd - dtStart + 1

    With Range("F2")
        .Offset(-1) = "Date"
        .Value = dtStart
        .DataSeries Rowcol:=xlColumns, Type:=xlChronological, Date:= _
                    xlDay, Step:=1, Stop:=Range("A" & Rows.Count).End(xlUp), Trend:=False
        With .Offset(, 1).Resize(NoDays)
            .Formula = "=COUNTIF(A:A, F2)"
            .Value = .Value
        End With
    End With

End Sub

Open in new window

0
 
dlmilleCommented:
Just place the data in the activesheet, and run the macro insertMissingDates().  There's a button on the sheet.

Here's the code:
 
Option Explicit

Sub insertMissingDates()
Dim sht As Worksheet
Dim myCell As Range
Dim firstDate As Date, lastDate As Date
Dim i As Date
Dim outCursor As Range
Dim fRange As Range

    Set sht = ActiveSheet
    firstDate = sht.Range("A2").Value
    lastDate = sht.Range("A" & sht.Rows.Count).End(xlUp).Value
    
    For i = firstDate To lastDate
        Set fRange = sht.Range("A:A").Find(what:=i, LookIn:=xlFormulas, lookat:=xlWhole)
        If Not fRange Is Nothing Then
            Set outCursor = fRange
        Else
            outCursor.Offset(1, 0).EntireRow.Insert
            Set outCursor = outCursor.Offset(1, 0)
            outCursor.Value = i
            outCursor.Offset(0, 1).Value = 0
        End If
    Next i
End Sub

Open in new window


Enjoy!

Dave
target123-r1.xlsm
0
 
dlmilleCommented:
Just a "nice to do" add.  This version prompts you for the CSV file and makes the change in that file.  Do with it what you want from there :)

Here's the revised code:

 
Option Explicit
Sub insertMissingDates()
Dim sht As Worksheet
Dim myCell As Range
Dim firstDate As Date, lastDate As Date
Dim i As Date
Dim outCursor As Range
Dim fRange As Range
Dim myWkb As Workbook
Dim fName As Variant

    Set sht = ActiveSheet
    fName = selectFile("", ActiveWorkbook.Path, "Select CSV file for date processing")
    If fName = "" Then Exit Sub 'must have canceled
    
    Set myWkb = Workbooks.Open(Filename:=fName)
    If myWkb Is Nothing Then
        MsgBox "Can't open the file: " & fName, vbCritical, "Aborting."
        Exit Sub
    End If
    
    Set sht = myWkb.ActiveSheet
    
    firstDate = sht.Range("A2").Value
    lastDate = sht.Range("A" & sht.Rows.Count).End(xlUp).Value
    
    For i = firstDate To lastDate
        Set fRange = sht.Range("A:A").Find(what:=i, LookIn:=xlFormulas, lookat:=xlWhole)
        If Not fRange Is Nothing Then
            Set outCursor = fRange
        Else
            outCursor.Offset(1, 0).EntireRow.Insert
            Set outCursor = outCursor.Offset(1, 0)
            outCursor.Value = i
            outCursor.Offset(0, 1).Value = 0
        End If
    Next i
    MsgBox "Processing Complete"
End Sub
Function selectFile(initFname As String, initPath As String, msg As String) As Variant
Dim wbk As Workbook
Dim fDialog As Office.FileDialog
Dim myPath As String

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    
    On Error GoTo errhandler

    Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
         
    If initPath = "" Then
        myPath = ThisWorkbook.Path
    Else
        myPath = initPath
    End If
    
    If Right(myPath, 1) <> "\" Then myPath = myPath & "\"
    
    With fDialog
        .AllowMultiSelect = False
        .Title = "Select File Location for Monthly Reimbursement Processing: " & msg
        .InitialView = msoFileDialogViewDetails
        .Filters.Clear
        .Filters.Add "TEXT Files", "*.CSV"
        .InitialFileName = initPath & initFname
        If .Show = True Then selectFile = .SelectedItems(1)
        .Filters.Clear
    End With
    
    Exit Function
    
errhandler:
    MsgBox "Error Selecting File/Folder #: " & Err.Number & "-> " & Err.Description, vbCritical, "Aborting"
    selectFile = False
End Function

Open in new window


See attached - open it, ensure macros are enabled, and click the macro button.

Enjoy!

Dave
target123-r2.xlsm
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.