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):
Regards,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
Robert




Reply With Quote
Bookmarks