Insert Missing Dates By Comparing Two Lists Of Dates

**mahmoud-lee** · 10-07-2013, 02:42 AM

hi Welcome Please, I want to compare the two columns in terms of date, such as the existing columns

**princ_wns** · 10-07-2013, 07:42 AM

Hi Lee,

Can you please explain it bit more, what exactly you want.

**mahmoud-lee** · 10-07-2013, 08:15 PM

I hope this will be explained

**mahmoud-lee** · 10-09-2013, 01:37 AM

This file may be explained

**Trebor76** · 10-09-2013, 06:23 PM

Hi mahmoud-lee,

This is much harder than it seems - well it was for me anyway (took me nearly 3 days on and off).

Anyway, let us know how this goes (hopefully good as it works for me):

Code:

Option Explicit
Sub Macro1()

    'Written by Trebor76
    'Visit my website www.excelguru.net.au
    
    'Match the dates in Col's D and E and output them to Col's L and M respectively.
    
    'http://www.excelfox.com/forum/f2/compare-between-two-dates-1497/

    Const lngStartRow As Long = 4 'Starting row number for the data. Change to suit.

    Dim objMyUniqueList As Object
    Dim strMyArray() As String
    Dim lngArrayCount As Long
    Dim lngEndRow As Long
    Dim lngListARow As Long, _
        lngListBRow As Long
    Dim rngCell As Range
    Dim dteMyDate As Date   
    Dim varUniqueItem As Variant
    Dim lngMatchCount As Long
    
    Application.ScreenUpdating = False
    
    Set objMyUniqueList = CreateObject("Scripting.Dictionary")
    
    lngEndRow = Range("D:E").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    'Create an unique array of dates from both columns.
    For Each rngCell In Range("D" & lngStartRow & ":E" & lngEndRow)
        If Len(rngCell) > 0 And IsDate(rngCell) = True Then
            dteMyDate = CDate(rngCell)
            If Not objMyUniqueList.Exists(dteMyDate) Then
                objMyUniqueList.Add dteMyDate, dteMyDate
                lngArrayCount = lngArrayCount + 1
                ReDim Preserve strMyArray(1 To lngArrayCount)
                strMyArray(lngArrayCount) = Format(dteMyDate, "yyyymmdd") 'Best format for sorting.
            End If
        End If
    Next rngCell
    
    'Need to sort the array in ascending sequence.
    'This nifty code was written by Hans Vogelaar MCC, MVP and is sourced from here: _
    'http://social.msdn.microsoft.com/Forums/en-US/830b42cf-8c97-4aaf-b34b-d860773281f7/sorting-an-array-in-vba-without-excel-function?forum=isvvba
    Call BubbleSort(strMyArray)
    
    'Initialise the 'lngListARow' and 'lngListBRow' variables to the 'lngStartRow' constant variable.
    lngListARow = lngStartRow: lngListBRow = lngStartRow
    
    For Each varUniqueItem In strMyArray()
        '**Note the 'dteMyDate' variable here must be in the same format (i.e. with dashes or slashes) as the dates are formatted within the cells**
        'Toggle through the unique dates and, using the COUNTIF function, output however many are required from Col. D into Col. L.
        dteMyDate = CDate(Mid(varUniqueItem, 5, 2) & "-" & Right(varUniqueItem, 2) & "-" & Left(varUniqueItem, 4))
        If Evaluate("COUNTIF($D$" & lngStartRow & ":$D$" & lngEndRow & ",""" & Format(dteMyDate, "d-mmm-yyyy") & """)") > 0 Then
            For lngMatchCount = 1 To Evaluate("COUNTIF($D$" & lngStartRow & ":$D$" & lngEndRow & ",""" & Format(dteMyDate, "d-mmm-yyyy") & """)")
                Cells(lngListARow, "L") = Format(CDate(dteMyDate), "mm/dd/yyyy") 'Output format can be changed here if desired.
                lngListARow = lngListARow + 1
            Next lngMatchCount
        End If
        'Toggle through the unique dates and, using the COUNTIF function, output however many are required from Col. E into Col. M.
        If Evaluate("COUNTIF($E$" & lngStartRow & ":$E$" & lngEndRow & ",""" & Format(dteMyDate, "d-mmm-yyyy") & """)") > 0 Then
            For lngMatchCount = 1 To Evaluate("COUNTIF($E$" & lngStartRow & ":$E$" & lngEndRow & ",""" & Format(dteMyDate, "d-mmm-yyyy") & """)")
                Cells(lngListBRow, "M") = Format(CDate(dteMyDate), "mm/dd/yyyy") 'Output format can be changed here if desired.
                lngListBRow = lngListBRow + 1
            Next lngMatchCount
        End If
        'Get the two output row numbers in sync.
        If lngListARow > lngListBRow Then
            lngListBRow = lngListARow
        ElseIf lngListBRow > lngListARow Then
            lngListARow = lngListBRow
        End If
    Next varUniqueItem
    
    'Remove objects from memory
    Set objMyUniqueList = Nothing
    Erase strMyArray()
        
    Application.ScreenUpdating = True
    
    MsgBox "The dates in columns D and E have matched to columns L and M.", vbInformation, "Excel Guru"

End Sub
Sub BubbleSort(arr)
    
    Dim strTemp As String
    Dim i As Long
    Dim j As Long
    Dim lngMin As Long
    Dim lngMax As Long
    
    lngMin = LBound(arr)
    lngMax = UBound(arr)
    
    For i = lngMin To lngMax - 1
        For j = i + 1 To lngMax
          If arr(i) > arr(j) Then
            strTemp = arr(i)
            arr(i) = arr(j)
            arr(j) = strTemp
          End If
        Next j
  Next i

End Sub

Regards,

Robert

**mahmoud-lee** · 10-11-2013, 01:03 PM

I am unfortunately not the required solution
I want it like this solution and I hope by the formula

**Excel Fox** · 10-11-2013, 01:37 PM

Why is 2nd and 3rd January missing in first column?

**mahmoud-lee** · 10-11-2013, 01:49 PM

Nothing
But I mean, any date that does not exist in the corresponding column writing (0) in the corresponding date
But when it is writing again ...... etc.
Because it is a comparison between columns (1) & (2)
I want them to like 3, 4

**Excel Fox** · 10-11-2013, 04:11 PM

What do you mean nothing?

All the attachments you are uploading are exactly the same, and you are not proving anything that way. My question is, why is 2nd and 3rd January missing in your final output?

If that was a mistake from your part, then try this code

Code:

Sub ExcelFox()


    Dim lng As Long:    lng = 4
    While Not (IsEmpty(Range("D" & lng).Value) Or IsEmpty(Range("E" & lng).Value))
        If Range("D" & lng).Value > Range("E" & lng).Value Then
            Range("D" & lng).Insert xlDown
        ElseIf Range("D" & lng).Value < Range("E" & lng).Value Then
            Range("E" & lng).Insert xlDown
        End If
        lng = lng + 1
    Wend
    
End Sub