Macro to Merge Sequential Dates in Rows

**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

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

True, the copy, change, then delete old data could work.

Or..is there any way we could move this data onto a new worksheet? As in, open up a new tab and paste the new adjusted info there?

**Richard Buttrey** · 03-23-2011, 06:30 AM

Hi,

Yes indeed.

Just add the following code after the last 'Loop' instruction

Cells(1, lColStart + 10).CurrentRegion.Offset(0, 1).Copy
Sheets.Add
ActiveSheet.Paste

Regards

**snb** · 03-23-2011, 07:02 AM

or

Sub snb()
  sq = Sheets(1).Cells(1).CurrentRegion
  For j = 2 To UBound(sq) - 1
    If sq(j, 1) & sq(j, 5) & sq(j, 6) & sq(j, 7) = sq(j + 1, 1) & sq(j + 1, 5) & sq(j + 1, 6) & sq(j + 1, 7) And sq(j + 1, 2) - sq(j, 3) = 1 Then
       sq(j, 3) = sq(j + 1, 3)
       sq(j, 4) = sq(j, 4) & " " & sq(j + 1, 4)
       sq(j, 8) = sq(j, 8) & " " & sq(j + 1, 8)
       sq(j + 1, 1) = ""
       j = j + 1
    End If
  Next

  With Sheets.Add
    .Cells(1).Resize(UBound(sq), UBound(sq, 2)) = sq
    .Columns(1).SpecialCells(4).EntireRow.Delete
 End With
End Sub

**MSmithson** · 03-23-2011, 12:25 PM

Thanks SNB, your code seems to do all the matching and merging correctly, but it also gets rid of all formatting such as fonts and colors. See attached file (your code is added). It removes all formatting from the header and notes columns. Any way to keep this? Thanks for your help.

**MSmithson** · 03-23-2011, 12:30 PM

Thanks Richard, however your code does not seem to do anything...the macro just stops after it merges the cells and copys the info into the same sheet. I also tried a few variations on the code and couldn't get it to delete the old rows - are the new cells somehow locked or something that prevents deleting the old cells? Thanks for the help.

**Richard Buttrey** · 03-23-2011, 12:56 PM

Hi,

Sorry, I'd forgotten that the macro finishes as soon as the If Test just after the Do While....is satisfied. This is where the extra lines are needed. Hence add the following 6 lines immediately after the Do While...

Do While stCurrent = stNext
        If Cells(lCount, lColStart) = "" Then
            Cells(1, lColStart + 10).CurrentRegion.Offset(0, 1).Copy
            Sheets.Add
            ActiveSheet.Paste
            End
        End If

**snb** · 03-23-2011, 12:58 PM

Have you any ideas yourself?
For instance copying the 'fieldnames' from one sheet to another ?
I have no clue on the formatting of cells and the relation between the formatting and the content.

As you have undoubtedly noticed analysing my suggestion, it only handles the content of the cells.