Merge identical cells in table

Hi Yasser,

You always seem to have interesting and challenging questions. Try the attached file which contains the following code:

Option Explicit

Public Const sSourceWorksheetName = "Basic"
Public Const sDestinationWorksheetName = "Merged"
Public Const sDestinationWorksheetTopLeftCell = "A21"

Public Const nSpecialBlueColorIndex = 37
Public Const nSpecialGrayColorIndex = 15

Sub ClearDestinationArea()

  Dim wsDestination As Worksheet
  Dim myBigRange As Range
  Dim myDataRange As Range

  'Create the Worksheet Object
  Set wsDestination = Sheets(sDestinationWorksheetName)

  'Get the Range on the Destination Sheet
  'Calculate the 'Data Range'
  'Add two rows and move up two rows to get the entire range
  Set myDataRange = wsDestination.Range(sDestinationWorksheetTopLeftCell)
  Set myBigRange = myDataRange.Resize(7, 27)
  myBigRange.UnMerge
  myBigRange.Clear
  Debug.Print myBigRange.Address
  
  
  'Clear Object Pointers
  Set wsDestination = Nothing
  Set myBigRange = Nothing
  Set myDataRange = Nothing

End Sub


Sub MergeCellsWithLikeData()

  Dim wsDestination As Worksheet
  Dim wsSource As Worksheet
  
  Dim r As Range
  Dim myBigRange As Range
  Dim myDataRange As Range
  Dim myMergedRange As Range
  
  Dim iCount As Long
  Dim iRangeEndRow As Long
  Dim iRangeStartRow As Long
  
  Dim sRange As String
  Dim sValue As String
  Dim sValuePrevious As String


  '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  'Initial Processing
  '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  
  'Disable Screen Updating to improve speed performance and to eliminate screen flicker
  Application.ScreenUpdating = False

  'Create the Worksheet Objects
  Set wsSource = Sheets(sSourceWorksheetName)
  Set wsDestination = Sheets(sDestinationWorksheetName)


  'Find the first occurence of .Sun on the Source Worksheet
  'Find the first occurence of the string
  'NOTE: .Find can not locate '.Sun', so looking for 'Sun' in part of the Cell
  Set r = wsSource.Cells.Find(What:="Sun", _
                      After:=wsSource.Range("A1"), _
                      LookIn:=xlValues, _
                      LookAt:=xlPart, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlNext, _
                      MatchCase:=False, _
                      SearchFormat:=False)
  
  If r Is Nothing Then
    MsgBox "NOTHING DONE.  Could not find data table on Sheet '" & sSourceWorksheetName & "'."
    GoTo MYEXIT
  End If
  
  '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  'Copy from the 'Source Area' to the 'Destination Area'
  '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  
  'Calculate the 'Data Range' on the Source Sheet
  'Add two rows and move up two rows to get the entire range
  Set myDataRange = r.CurrentRegion
  Set myBigRange = myDataRange.Resize(myDataRange.Rows.Count + 2)
  Set myBigRange = myBigRange.Offset(-2)
  
  'Get the Start Row and End Row of the Big Range on the Source Sheet
  'Copy the Range to the Destination Sheet
  iRangeStartRow = myBigRange.Row
  iRangeEndRow = iRangeStartRow + myBigRange.Rows.Count - 1
  sRange = iRangeStartRow & ":" & iRangeEndRow
  wsSource.Range(sRange).Copy Destination:=wsDestination.Range(sDestinationWorksheetTopLeftCell)
  
  
  '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  'Color and Merge Cells in the Destination Area
  '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  
  'Get the Range on the Destination Sheet
  'Calculate the 'Data Range'
  'Add two rows and move up two rows to get the entire range
  Set myDataRange = wsDestination.Range(sDestinationWorksheetTopLeftCell).Offset(2, 0).CurrentRegion
  Set myBigRange = myDataRange.Resize(myDataRange.Rows.Count + 2)
  Set myBigRange = myBigRange.Offset(-2)
  
  
  'Color each Cell in the First Row 'Special Blue'
  For Each r In myBigRange.Resize(1)
    r.Interior.ColorIndex = nSpecialBlueColorIndex
  Next r
  
  'Color each Cell in the Next Row 'Special Gray'
  For Each r In myBigRange.Resize(1).Offset(1)
    r.Interior.ColorIndex = nSpecialGrayColorIndex
  Next r
  
  'Color every 9th Cell Special Gray (starting at the first cell in each row)
  'Merge adjacent cells if the values are the same (reset after a merge)
  iCount = 0
  For Each r In myDataRange
  
    'Initialize the Counter that counts to 9
    'Get the next value from the 'Destination Data Area'
    iCount = iCount + 1
    sValue = Trim(r.Value)
    
    If iCount = 1 Then
      'Color every 9th Cell Special Gray
      r.Interior.ColorIndex = nSpecialGrayColorIndex
    
    ElseIf sValue = sValuePrevious Then
        'Merge adjacent cells with the same value
        'Clear the value in the rightmost cell to avoid an Excel Warning message
        'Create a 'Merged Range' that includes the two cells (this cell and the cell to the left)
        'Clear the 'Curent Value' to avoid 3 matches in a row
        r.Value = ""
        Set myMergedRange = r.Offset(0, -1).Resize(, 2)
        myMergedRange.Merge
        sValue = ""
      
    End If
    
    'Reset the counter when it reaches 9
    If iCount = 9 Then
      iCount = 0
    End If
      
    'Save the 'Current Value' for future use
    sValuePrevious = sValue
    
  Next r

MYEXIT:
  'Enable Screen Updating
  Application.ScreenUpdating = True
  
  'Clear Object Pointers
  Set wsSource = Nothing
  Set wsDestination = Nothing
  Set r = Nothing
  Set myBigRange = Nothing
  Set myDataRange = Nothing
  Set myMergedRange = Nothing
End Sub

Lewis