Colouring variable text within a cell / string, and merging a variable number of cells

Hi Steve,

Try the following Macro which is also implemented in the attached file.

Lewis

Option Explicit


Sub ColorCellTextManyColors()

  Const myColorIndexOPEN = 1          'ColorIndex  1 = Black
  Const myColorIndexCOMPLETE = 15     'ColorIndex 15 = Gray
  Const myColorIndexOVERDUE = 3       'ColorIndex  3 = Red

  Dim wsSource As Worksheet
  Dim wsDestination As Worksheet
  
  Dim myCell As Range
  
  Dim myDueDate As Date
  Dim myToday As Date
  
  Dim iColorIndexThisRow As Long
  Dim iCountThisId As Long
  Dim iDestinationRow As Long
  Dim iFirstRowInMergedCell As Long
  Dim iFirstSourceRow As Long
  Dim iIdColumn As Long
  Dim iLastSourceRow As Long
  Dim iSourceRow As Long

  Dim sActionDescription As String
  Dim sDateOutputText As String
  Dim sId As String
  Dim sIdPrevious As String
  Dim sRange As String
  Dim sStatus As String
  Dim sStatusOutputText As String
  Dim sDueDate As String

  'Create the Worksheet Objects
  Set wsSource = Sheets("Sheet1")
  Set wsDestination = Sheets("Results")
  
  'Clear the Destination Sheet and reinitialize the Column Widths
  wsDestination.Cells.Clear
  wsDestination.Columns.ColumnWidth = 8.42
  
  'Put in the Destination SheetHeader Row
  iDestinationRow = 1
  wsDestination.Cells(iDestinationRow, "A") = "ID"
  wsDestination.Cells(iDestinationRow, "B") = "Action Description"
  wsDestination.Cells(iDestinationRow, "C") = "Status / Due Date"
  
  wsDestination.Cells(iDestinationRow, "A").HorizontalAlignment = xlLeft
  wsDestination.Cells(iDestinationRow, "B").HorizontalAlignment = xlLeft
  wsDestination.Cells(iDestinationRow, "C").HorizontalAlignment = xlLeft
  
  wsDestination.Cells(iDestinationRow, "A").Font.Bold = True
  wsDestination.Cells(iDestinationRow, "B").Font.Bold = True
  wsDestination.Cells(iDestinationRow, "C").Font.Bold = True
  
  
  'Initialize the value of Today
  myToday = Date
  
  'Find the Last Row in the Source Worksheet
  iLastSourceRow = wsSource.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

  'Find the Cell that Contains 'ID'
  Set myCell = LjmFindFirst(wsSource, "ID")
  
  'Stop if there is NO 'ID' Header in the Source Sheet
  If myCell Is Nothing Then
    MsgBox "NOTHING DONE." & vbCrLf & _
           "There is NO Cell that contains the Header Text 'ID'."
    GoTo MYEXIT
  End If
  
  'Get the First Source Data Row and the 'ID' Data Column from the 'ID' Header Cell address
  iFirstSourceRow = myCell.Row + 1
  iIdColumn = myCell.Column
  
  'Process the Source Data one row at a time
  For iSourceRow = iFirstSourceRow To iLastSourceRow
  
    'Read data from the 'Id' Column and the next 3 columns
    sId = Trim(wsSource.Cells(iSourceRow, iIdColumn).Offset(0, 0).Value)
    sActionDescription = Trim(wsSource.Cells(iSourceRow, iIdColumn).Offset(0, 1).Value)
    sStatus = Trim(wsSource.Cells(iSourceRow, iIdColumn).Offset(0, 2).Value)
    sDueDate = Trim(wsSource.Cells(iSourceRow, iIdColumn).Offset(0, 3).Value)
    
    'Increment (or Initialize) the 'ID' Counter
    If sId = sIdPrevious Then
      iCountThisId = iCountThisId + 1
    Else
      iCountThisId = 1
    End If
    'Debug.Print "'''''''''''''''"
    'Debug.Print sId
    'Debug.Print Format(iCountThisId, "0. ") & sActionDescription
    'Debug.Print Format(iCountThisId, "0. ") & sStatus & ", " & Format(sDueDate, "dd/mm/yyyy")
    'Debug.Print "'''''''''''''''"
    
    
    If UCase(Trim(sStatus)) = "CLOSED" Then
      'Perform 'CLOSED' Status processing
      sStatusOutputText = sStatus
      iColorIndexThisRow = myColorIndexCOMPLETE
      If IsDate(sDueDate) Then
        sDateOutputText = ", Complete " & Format(myDueDate, "dd/mm/yyyy")
      Else
        sDateOutputText = ""
      End If
    Else
      'Perform 'OPEN' Status processing
      If IsDate(sDueDate) Then
        myDueDate = CDate(sDueDate)
        If myDueDate > myToday Then
         ''OPEN' Status
          sStatusOutputText = sStatus
          iColorIndexThisRow = myColorIndexOPEN
          sDateOutputText = ", Due " & Format(myDueDate, "dd/mm/yyyy")
        Else
         ''OVERDUE' Status
          sStatusOutputText = "Overdue"
          iColorIndexThisRow = myColorIndexOVERDUE
          sDateOutputText = ", " & Format(myDueDate, "dd/mm/yyyy")
        End If
      Else
        ''OPEN' Status with NO 'Due Date'
        iColorIndexThisRow = myColorIndexOPEN
        sDateOutputText = ""
      End If
    End If
    
    'Output the Results for this row
    iDestinationRow = iDestinationRow + 1
    If iCountThisId = 1 Then
      wsDestination.Cells(iDestinationRow, "A") = sId
    Else
      'Create Merged Cells if the count is greater than one
      iFirstRowInMergedCell = iDestinationRow - iCountThisId + 1
      sRange = "A" & iFirstRowInMergedCell & ":A" & iDestinationRow
      wsDestination.Range(sRange).MergeCells = True
      wsDestination.Range(sRange).VerticalAlignment = xlTop
      'Debug.Print sRange
    End If
    wsDestination.Cells(iDestinationRow, "B") = Format(iCountThisId, "0. ") & sActionDescription
    wsDestination.Cells(iDestinationRow, "C") = Format(iCountThisId, "0. ") & sStatusOutputText & sDateOutputText
    
    wsDestination.Cells(iDestinationRow, "A").HorizontalAlignment = xlLeft
    wsDestination.Cells(iDestinationRow, "B").HorizontalAlignment = xlLeft
    wsDestination.Cells(iDestinationRow, "C").HorizontalAlignment = xlLeft
    
    wsDestination.Cells(iDestinationRow, "B").Font.ColorIndex = iColorIndexThisRow
    wsDestination.Cells(iDestinationRow, "C").Font.ColorIndex = iColorIndexThisRow
    
    'Debug.Print iSourceRow, iDestinationRow, sId, sActionDescription, sStatus, sDueDate
    
    'Save the ID value for use in the next pass
    sIdPrevious = sId
  Next iSourceRow
  
  'Put the data in PRETTYPRINT format
  wsDestination.Columns("A:C").Columns.AutoFit
  wsDestination.Columns("A").ColumnWidth = wsDestination.Columns("A").ColumnWidth + 4
  wsDestination.Columns("B").ColumnWidth = wsDestination.Columns("B").ColumnWidth + 4
  wsDestination.Columns("C").ColumnWidth = wsDestination.Columns("C").ColumnWidth + 4
  

MYEXIT:
  'Clear object pointers
  Set wsSource = Nothing
  Set wsDestination = Nothing


End Sub

Function LjmFindFirst(ws As Worksheet, sFindString As String) As Range
  'This returns the address (as a string) of the first occurrence of a 'find string'
  
  Dim r As Range
  
  'Find the first occurence of the string
  Set r = Nothing
  Set r = ws.Cells.Find(What:=sFindString, _
                      After:=ws.Range("A1"), _
                      LookIn:=xlValues, _
                      LookAt:=xlWhole, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlNext, _
                      MatchCase:=False, _
                      SearchFormat:=False)
                      
                      
  If Not r Is Nothing Then
  
    'Save the found address as the return value as a string
    Set LjmFindFirst = r
  Else
    If UCase(Trim(ws.Range("A1").Value)) = UCase(Trim(sFindString)) Then
      Set LjmFindFirst = ws.Range("A1")
    End If
  End If
 
  'Clear the object pointer
  Set r = Nothing
 
End Function