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

**Steve M.** · 02-16-2015, 06:14 PM

Hi

I've spent far too many hours at work today trying to figure out how to do a couple things and am hoping someone can help. Basically I'm dealing with registers and for example, one entry (with a particular reference number) may have several actions associated with it (which appear in different rows) and each action would have a due date next to it. What I want to do is to be able to put all the actions in one cell, and colour the actions that are complete as grey, and the ones that are late in red, and I'm really struggling.

Here is what the raw data would look like:

ID	Action Description	Status	Due Date
3001	Description 1	Open	10/03/15
3001	Description 2	Closed	01/01/15
3001	Description 3	Open	01/02/15
3002	Description 4	Closed	01/12/14
3002	Description 5	Open	15/11/14

And what I want the output to look like is:

ID	Action Description	Status / Due Date
3001	1. Description 1 2. Description 2 3. Description 3	1. Open, Due 10/03/15 2. Closed, Complete 01/01/15 3. Overdue, 01/02/15
3002	1. Description 4 2. Description 5	1. Closed, Complete 01/01/15 2. Overdue, 15/11/14

The number of different descriptions per ID would vary from none to many, the length of each description varies significantly, and there needs to be an unlimited number of IDs that could be present in the register (i.e. I may have 200 different IDs, each of them with numerous descriptions of actions, and each of those with a due date that is either not there, is late, or is in the future, so would need to be colour-coded).

Joining the Status and Due date columns are not a problem, but I'm struggling with joining the different rows (of the same ID) and then colour-coding the necessary text within those cells.

Any thoughts would be appreciated as I'm truly stuck.

Cheers

Steve

**Steve M.** · 02-17-2015, 10:41 AM

Slight update - I've now got the merging the cells all sorted so it's just the changing the colours within the cells I'm now missing.

**LJMetzger** · 02-17-2015, 06:17 PM

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

**jindon** · 02-17-2015, 11:53 PM

Try the attached

Sub test()
    Dim a, i As Long, pref As String, e
    Dim rng As Range, r As Range, mtch As Object, m As Object, s As Object
    a = Cells(1).CurrentRegion.Value
    a(1, 3) = "Status / Due Date"
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a, 1)
            If a(i, 3) = "Closed" Then
                pref = a(i, 3) & ", Completed "
            Else
                pref = IIf(a(i, 4) < Date, "Over ", "") & "Due, "
            End If
            If Not .exists(a(i, 1)) Then
                .Item(a(i, 1)) = .Count + 2
                a(.Item(a(i, 1)), 1) = a(i, 1)
                a(.Item(a(i, 1)), 2) = "1. " & a(i, 2)
                a(.Item(a(i, 1)), 3) = "1. " & pref & Format$(a(i, 4), "yyyy/m/d")
                a(.Item(a(i, 1)), 4) = 1
            Else
                a(.Item(a(i, 1)), 4) = a(.Item(a(i, 1)), 4) + 1
                a(.Item(a(i, 1)), 2) = a(.Item(a(i, 1)), 2) & vbLf & _
                a(.Item(a(i, 1)), 4) & ". " & a(i, 2)
                a(.Item(a(i, 1)), 3) = a(.Item(a(i, 1)), 3) & vbLf & _
                a(.Item(a(i, 1)), 4) & ". " & pref & Format$(a(i, 4), "yyyy/m/d")
            End If
        Next
        i = .Count
    End With
    Set rng = [g1].Resize(i + 1, 3)
    rng.Clear
    rng.Value = a
    With CreateObject("VBScript.RegExp")
        .Global = True: .MultiLine = True
        For Each r In rng.Columns(3).Cells
            For Each e In Array("Completed", "Over Due")
                .Pattern = "^(\d+).+" & e & ".+"
                If .test(r.Value) Then
                    Set mtch = .Execute(r.Value)
                    For Each m In mtch
                        .Pattern = "^" & m.submatches(0) & ".+"
                        Set s = .Execute(r(, 0).Value)(0)
                        r.Characters(m.firstindex + 1, m.Length).Font.ColorIndex = _
                        Switch(e = "Completed", 15, e = "Over Due", 3)
                        r(, 0).Characters(s.firstindex + 1, s.Length).Font.ColorIndex = _
                        Switch(e = "Completed", 15, e = "Over Due", 3)
                    Next
                End If
            Next
        Next
    End With
End Sub

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

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

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

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

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

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

Thread Information

Users Browsing this Thread

Similar Threads

[SOLVED] Sum individual day's data but merging variable number of cells problem.

[SOLVED] Calculate average of variable number of cells variable number of times

[SOLVED] Need to use a text string from another cell as a variable range in another equation.

Adding a variable string comment to a cell. "Object Variable or WIth Block Variable Not.."

Merging the correct number of cell rows to fit a string of wrapped text

Bookmarks

Bookmarks

Posting Permissions