Macro to Merge Sequential Dates in Rows

**MSmithson** · 03-22-2011, 02:06 PM

Hello all,

Trying to write a macro that will merge sequential dates within two or more rows.

I have the columns Title, Start Date, End Date, Format, Rights1, Rights2, Rights3 and Notes. These columns can be in any column letter, which is why I’d like to use the header in row 1 to identify these columns.

If the Title matches the column below, and Rights1, Rights2, and Rights3 all match and the dates are sequential, then merge these two rows into one row with the earliest start date and the last end date in the start and end date columns. The Format and Notes columns are merged together so no data in these columns is lost in the merge.

See examples 1 and 2 in attached sheet "Sequential Dates Merge".

Notice that on the first example, the Start Date of 3/22/11 is used and the End Date is 3/30/11 is used in the merged row. This is because the End Dates of 3/25/11 and 3/26/11 are sequential. The Formats are merged together and the Notes columns are merged together keeping any formatting such as font and color.

Since I’m working with up to several thousand rows, the macro may have to start at the last row and work it’s way up, using a -1 instead of a +1 for the sequential dates.

Something like: IF (Title = Title) and (start date = start date -1) and (end date = end date -1) and (Rights1 = Rights1) and (Rights2 = Rights2) and (Rights3 = Rights3) THEN

Merge (Union) of Rows and Merge Format and Notes columns together to include any data in rows into new row.

Any help at all is most appreciated – thank you so much!

Question also posed at mrexcel: http://www.mrexcel.com/forum/showthread.php?t=537943

**Richard Buttrey** · 03-22-2011, 02:56 PM

Hi,

And what if there is a non sequential End/Start date within the same Title?

Do you
a) ignore the whole series
b) merge the rows up to the break and move to the next title
c) merge the rows up to the break and continue in the same title looking for further matches
d) something else

Regards

**MSmithson** · 03-22-2011, 03:16 PM

Thanks Richard, I should have mentioned that in my original post.

If there is a non-sequential Start/End Date within the same title, then do option c:

c) merge the rows up to the break and continue in the same title looking for further matches

If there are no sequential Start/End Dates within a title, then the macro moves on to the next title.

If there are sequential Start/End Dates within a title, but the rights do not match in any one of the three columns, then do not merge, but continue to look for further matches within the title.

Thanks for asking the question.

**Richard Buttrey** · 03-22-2011, 07:45 PM

Hi,

It's a bit rough & ready and could no doubt be smartened up a bit with a little more thought but the following seems to work as you expect.

Sub MergeRows()
    Dim lColStart As Long, stCurrent As String, stNext As String, lCount As Long, stFormat As String, stNotes As String
    Dim dtStart As Date, dtEnd As Date, lcount2 As Long
    Dim rTempNotes As Range, lTempStart As Long

    lColStart = Range("1:1").Find("Title").Column
    Set rTempNotes = Cells(1, lColStart + 9)

    Range(Range("A1").Cells(1, lColStart), Range("A1").Cells(1, lColStart).End(xlToRight)).Copy
    Range("A1").Cells(1, lColStart + 10).PasteSpecial (xlPasteAll)

    lCount = 2
        Do While stCurrent = stNext
            If Cells(lCount, lColStart) = "" Then End
            lTempStart = Len(stNotes)
            stCurrent = Cells(lCount, lColStart) & Cells(lCount, lColStart + 4) & Cells(lCount, lColStart + 5) & Cells(lCount, lColStart + 6) & Cells(lCount, lColStart + 2)
            stNext = Cells(lCount + 1, lColStart) & Cells(lCount + 1, lColStart + 4) & Cells(lCount + 1, lColStart + 5) & Cells(lCount + 1, lColStart + 6) & Cells(lCount + 1, lColStart + 1) - 1

            If stCurrent = stNext Then
                dtStart = Cells(lCount, lColStart + 1)
                stFormat = stFormat & " " & Cells(lCount, lColStart + 3)
                stNotes = stNotes & " " & Cells(lCount, lColStart + 7)
                rTempNotes = stNotes
                rTempNotes.Characters(Start:=lTempStart, Length:=Len(stNotes)).Font.ColorIndex = Cells(lCount, lColStart + 7).Font.ColorIndex
                lCount = lCount + 1
            Else
                stFormat = stFormat & " " & Cells(lCount, lColStart + 3)
                stNotes = stNotes & " " & Cells(lCount, lColStart + 7)
                rTempNotes = stNotes
                rTempNotes.Characters(Start:=lTempStart + 1, Length:=Len(stNotes)).Font.ColorIndex = Cells(lCount, lColStart + 7).Font.ColorIndex
                dtEnd = Cells(lCount, lColStart + 2)
                Range("A" & Rows.Count).Offset(0, lColStart + 9).End(xlUp).Offset(1, 0) = Cells(lCount, lColStart)
                Range("A" & Rows.Count).Offset(0, lColStart + 10).End(xlUp).Offset(1, 0) = dtStart
                Range("A" & Rows.Count).Offset(0, lColStart + 11).End(xlUp).Offset(1, 0) = dtEnd
                Range("A" & Rows.Count).Offset(0, lColStart + 12).End(xlUp).Offset(1, 0) = stFormat
                Range("A" & Rows.Count).Offset(0, lColStart + 13).End(xlUp).Offset(1, 0) = Cells(lCount, lColStart + 4)
                Range("A" & Rows.Count).Offset(0, lColStart + 14).End(xlUp).Offset(1, 0) = Cells(lCount, lColStart + 5)
                Range("A" & Rows.Count).Offset(0, lColStart + 15).End(xlUp).Offset(1, 0) = Cells(lCount, lColStart + 4)
                rTempNotes.Copy Destination:=Range("A" & Rows.Count).Offset(0, lColStart + 16).End(xlUp).Offset(1, 0)
                stFormat = ""
                stNotes = ""
                stCurrent = ""
                stNext = ""
                lCount = lCount + 1
            End If
        Loop

End Sub

Regards

**MSmithson** · 03-22-2011, 07:58 PM

Hi Richard,

Thank you so much for your help - I really appreciate the time you put into this.

One thing (and maybe I should have been more clear in my example or written it in a different way), but instead of copying and pasting all the data into a new section on the same sheet, is there any way the macro can simply adjust the existing data where it is? No need to copy or move anything. I just used the before and after in the same sheet to illustrate the difference.

Your macro seems to do all the merging and matching just fine - just wondering if there is a way we can perform these calculations on existing data and not copy or move. Does this make sense? Sorry if I had caused any confusion in my example and again, I appreciate the help.

**MSmithson** · 03-22-2011, 08:03 PM

Attached is an example: Sheet1 and Sheet1 (2) are the before and after picture of the same sheet. Title1 merges into one row because the dates are sequential and all other criteria holds true. Title2 does not because one of the rights does not match. Thanks for the help.

**Richard Buttrey** · 03-22-2011, 08:21 PM

Hi,

I'd be inclined not to try and change a range which you're currently working with. That seems to me fraught with potential problems.

However you could achieve the same result, finishing the macro with a deletion of the original data and then cutting and pasting the resultant data back in place of the original.

Regards