Merge Cells for Unique Date

[slhangen]

I would like to be able to automate the following solution using macro or VBA:
I need to assign a supervisor for each unique date. Date may have more than one activity. Was wondering if it is possible to merge supervisor cells when multiple activities occur on same date. Not most elegant solution and I have no idea how to do it except manually, which would take way too much time.

Any help is greatly appreciated.

 

[Micron]

try this on a copy of your sheet. Guessing that it is col G that you want to merge. If not, change G. Seems to work with limited testing.

Sub MergeCells()
Dim i As Integer, n As Integer, LRow As Long

On Error GoTo errHandler
Application.EnableEvents = False
LRow = Cells(Rows.count, "A").End(xlUp).Row
i = 1 'start loop with i as 1

Do Until i >= LRow 'stop when i = count of last empty row in col A
   n = i 'sync n with i
   If IsEmpty(Cells(i + 1, 1)) Then 'check if cell below i is empty. If so, it needs to merge.
      Do Until Not IsEmpty(Cells(n + 1, 1)) 'get last empty cell before next date
         n = n + 1 'n now equals that cell number in A
         If n >= LRow Then 'make sure inner loop can't exceed coun of used cells in A
           Exit Do
           Exit Sub
         End If
      Loop
      Range("G" & i & ":" & "G" & n).Merge 'merge G from i to n
       i = n 'sync i to n because n rows have been merged
   End If
   i = i + 1
Loop

exitHere:
Application.EnableEvents = True
Exit Sub

errHandler:
MsgBox "Error " & Err.Number & ": " & Err.Description
Resume exitHere

 

[Micron]

Come to think of it, the starting position possibly should be something other than the beginning each time? If it never slows down then no issue. Not sure what you'd use for figuring out the starting point though - can't be the last merge because anybody could merge in the column anywhere. Maybe a column not in use yet. Something to think about if the rows get into the tens of thousands.

 

[slhangen]

Thanks for your assistance. I am getting the following error:

 

[Micron]

My post missed the End Sub line - sorry about that. It was just a copy/paste error.
The message pretty much tells you what the problem is. The blue highlight even shows you where to put it.

 

[slhangen]

Works perfectly. Thank You so much, Micron!

 

[Micron]

Great, thanks!