Bold and color text

[aledebortoli]

Good Afternoon

I have this code and in the following

If oCell <> Codei Or iCell <> ID Or gCell <> Px Or fCell <> Pr Then
dCell.Value = Codei & " " & "x" & Px & "+" & Pxc & " " & Pr & " " & Nts

I would have the Nts bolded and text in red but I cannot find a solution.

Can you please help me ?

Here is the full code

Thanks



Sub Bookings()

Dim Rm As Range, Dt As Range, Myrng As Range, Staff As Range
Dim endCol As Range, StCol As Range, StRow As Range, endRow As Range
Dim Codei As Range, Col As Range, Px As Range, Pxc As Range, ID As Range, orange As Range, Nts As Range
Dim rng As Range
Dim Pr As Integer
Pr = 32767
Dim i As String
Dim Dws As Worksheet, Cws As Worksheet
Dim X As Integer
Dim LastRow As Long
Dim aCell As Range, bCell As Range, dCell As Range
Dim oCell As Variant
Dim iCell As Variant
Dim gCell As Variant
Dim fCell As Variant
Dim eCell As Variant
Dim hCell As Variant

On Error Resume Next
'variables
Set Cws = Sheet1
Set Dws = Sheet2
Set StCol = Cws.Range("I5")
Set endCol = Cws.Range("K5")
Set StRow = Cws.Range("M5")
Set endRow = Cws.Range("O5")


'filter the data to limit
FilterRng
'set the range to loop through
LastRow = Dws.Range("AI" & Rows.Count).End(xlUp).Row
Set Myrng = Dws.Range("AI7:AI" & LastRow)

'set the range to loop through
'LastRow = Dws.Range("C" & Rows.Count).End(xlUp).Row
'Set Myrng = Dws.Range("C7:C" & LastRow) 'data sheet columns
'clear the values from the calendar
Cws.Range("G12:AK94").ClearContents
Cws.Range("G12:AK94").Interior.ColorIndex = xlNone
'LOOP 1"""""""""""""""""""""""""""""""
'set the variable for the number of rows and loop through
For X = StRow To endRow
Set Staff = Cws.Cells(X, 6)
'LOOP 2"""""""""""""""""""""""""""""'
'loop through column range
For Each dCell In Cws.Range(Cells(X, StCol), Cells(X, endCol))
If Not dCell Is Nothing Then
'set the date variable
Set Dt = Cells(10, dCell.Column)
'FIND FUNCTION""""""""""""""""""""
'find the rooms
Set aCell = Myrng.Find(What:=Staff, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
'set the room variable
Set bCell = aCell
'LOOP 3"""""""""""""""""""""""
'loop through the filtered data
Do
'find the next room with a booking
Set aCell = Myrng.FindNext(After:=aCell)
'establish the dates to add
'codice per lunghezza colore booking 0,1 valore start data 0,2 valore end data
If aCell.Offset(0, 1).Value <= Dt.Value And aCell.Offset(0, 2).Value >= Dt.Value Then
'set the variables
Set Codei = aCell.Cells(1, 5)
'Set Codei = aCell.Cells(1, 5)
Set Col = aCell.Cells(1, 4) 'status
Set Px = aCell.Cells(1, 6) ' number of adult
Set Pxc = aCell.Cells(1, 7) ' number of children
Pr = aCell.Cells(1, 13) ' price
Set ID = aCell.Offset(0, -1) 'ID
Set Nts = aCell.Cells(1, 15) ' Notes
'add the names and reassign after once
If oCell <> Codei Or iCell <> ID Or gCell <> Px Or fCell <> Pr Then
dCell.Value = Codei & " " & "x" & Px & "+" & Pxc & " " & Pr & " " & Nts
Set oCell = Codei
Set iCell = ID
Set gCell = Px
fCell = Pr
Set eCell = Pxc
Set hCell = Nts


End If

'add the coloring
Select Case Col
Case Cws.Range("AR9").Value
dCell.Interior.ColorIndex = 43
Case Cws.Range("AR10").Value
dCell.Interior.ColorIndex = 3
Case Cws.Range("AR11").Value
dCell.Interior.ColorIndex = 38
Case Cws.Range("AR12").Value
dCell.Interior.ColorIndex = 37
Case Cws.Range("AR13").Value
dCell.Interior.ColorIndex = 48
'Case Cws.Range("AR18").Value
'dCell.Interior.ColorIndex = 37
'Case Cws.Range("AR19").Value
'dCell.Interior.ColorIndex = 37
'Case Cws.Range("AR22:AR27").Value
'dCell.Interior.ColorIndex = 27

End Select
End If
'exit when values are found
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
Else
Exit Do
End If
Loop 'LOOP 3 end
' """""""""""""""""""""""""""""""""""""""""""""'
End If
End If
Next dCell 'LOOP 2 end
' """"""""""""""""""""""""""""""""""""""""""""""
Next X 'LOOP 1 end
' """"""""""""""""""""""""""""""""""""""""""""""""'
On Error GoTo 0
End Sub

 

[Kaper]

Try:

Dim mystr As String, ntsstr As String 'this line could go to the top of procedure, where other declartions are listed

If oCell <> Codei Or iCell <> ID Or gCell <> Px Or fCell <> Pr Then
  ntsstr = Nts
  mystr = Codei & " x" & Px & "+" & Pxc & " " & Pr & " " 
  With dCell
    .Value = mystr & ntsstr
    With .Characters(Start:=Len(mystr) + 1, Length:=Len(ntsstr)).Font
      .FontStyle = "Bold"
      .Color = vbRed
    End With
  End With

BTW. Please note how CODE tags improve readability of the VBA code

 

[aledebortoli]

Hi Kaper,
Thanks a lot for your reply.
With your solution I have all the text in red. What I would have is just Nts in red and Codei & " x" & Px & "+"& Pxc & " "&> Pr & " " in black ( as normal )

How can I change the code ?

Thanks a lot in advance

 

[aledebortoli]

Here is the code that I have now:

Sub Bookings()

Dim Rm As Range, Dt As Range, Myrng As Range, Staff As Range
Dim endCol As Range, StCol As Range, StRow As Range, endRow As Range
Dim Codei As Range, Col As Range, Px As Range, Pxc As Range, ID As Range, orange As Range, Nts As Range
Dim mystr As String, ntsstr As String
Dim Pr As Integer
Pr = 32767
Dim i As String
Dim Dws As Worksheet, Cws As Worksheet
Dim X As Integer
Dim LastRow As Long
Dim aCell As Range, bCell As Range, dCell As Range
Dim oCell As Variant
Dim iCell As Variant
Dim gCell As Variant
Dim fCell As Variant
Dim eCell As Variant


On Error Resume Next
'variables
Set Cws = Sheet1
Set Dws = Sheet2
Set StCol = Cws.Range("I5")
Set endCol = Cws.Range("K5")
Set StRow = Cws.Range("M5")
Set endRow = Cws.Range("O5")


'filter the data to limit
FilterRng
'set the range to loop through
LastRow = Dws.Range("AI" & Rows.Count).End(xlUp).Row
Set Myrng = Dws.Range("AI7:AI" & LastRow)

'set the range to loop through
'LastRow = Dws.Range("C" & Rows.Count).End(xlUp).Row
'Set Myrng = Dws.Range("C7:C" & LastRow) 'data sheet columns
'clear the values from the calendar
Cws.Range("G12:AK94").ClearContents
Cws.Range("G12:AK94").Interior.ColorIndex = xlNone
'LOOP 1"""""""""""""""""""""""""""""""
'set the variable for the number of rows and loop through
For X = StRow To endRow
Set Staff = Cws.Cells(X, 6)
'LOOP 2"""""""""""""""""""""""""""""'
'loop through column range
For Each dCell In Cws.Range(Cells(X, StCol), Cells(X, endCol))
If Not dCell Is Nothing Then
'set the date variable
Set Dt = Cells(10, dCell.Column)
'FIND FUNCTION""""""""""""""""""""
'find the rooms
Set aCell = Myrng.Find(What:=Staff, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
'set the room variable
Set bCell = aCell
'LOOP 3"""""""""""""""""""""""
'loop through the filtered data
Do
'find the next room with a booking
Set aCell = Myrng.FindNext(After:=aCell)
'establish the dates to add
'codice per lunghezza colore booking 0,1 valore start data 0,2 valore end data
If aCell.Offset(0, 1).Value <= Dt.Value And aCell.Offset(0, 2).Value >= Dt.Value Then
'set the variables
Set Codei = aCell.Cells(1, 5)
Set Col = aCell.Cells(1, 4) 'status
Set Px = aCell.Cells(1, 6) ' number of adult
Set Pxc = aCell.Cells(1, 7) ' number of children
Pr = aCell.Cells(1, 13) ' price
Set ID = aCell.Offset(0, -1) 'ID
Set Nts = aCell.Cells(1, 15) ' Notes
'add the names and reassign after once
If oCell <> Codei Or iCell <> ID Or gCell <> Px Or fCell <> Pr Then
ntsstr = Nts
mystr = Codei & " x " & Px & "+" & Pxc & " " & Pr & " "
With dCell
.Value = mystr & ntsstr
With .Characters(Start:=Len(mystr), Length:=Len(ntsstr)).Font
.FontStyle = "Bold"
.Color = vbRed
End With
End With
Set oCell = Codei
Set iCell = ID
Set gCell = Px
fCell = Pr
Set eCell = Pxc
Set hCell = Nts

End If
'add the coloring
Select Case Col
Case Cws.Range("AR9").Value
dCell.Interior.ColorIndex = 43
Case Cws.Range("AR10").Value
dCell.Interior.ColorIndex = 3
Case Cws.Range("AR11").Value
dCell.Interior.ColorIndex = 38
Case Cws.Range("AR12").Value
dCell.Interior.ColorIndex = 37
Case Cws.Range("AR13").Value
dCell.Interior.ColorIndex = 48
'Case Cws.Range("AR18").Value
'dCell.Interior.ColorIndex = 37
'Case Cws.Range("AR19").Value
'dCell.Interior.ColorIndex = 37
'Case Cws.Range("AR22:AR27").Value
'dCell.Interior.ColorIndex = 27

End Select
End If
'exit when values are found
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
Else
Exit Do
End If
Loop 'LOOP 3 end
' """""""""""""""""""""""""""""""""""""""""""""'
End If
End If
Next dCell 'LOOP 2 end
' """"""""""""""""""""""""""""""""""""""""""""""
Next X 'LOOP 1 end
' """"""""""""""""""""""""""""""""""""""""""""""""'
On Error GoTo 0
End Sub



But like this when I have something in Nts it works well (mystr is in black and only nts is in red ) but if Nts is empty it shows mystr in red.

 

[Kaper]

try:

With dCell
  .Value = mystr & ntsstr
  .font.color = vbBlack
  if len(ntsstr)>0 then
    With .Characters(Start:=Len(mystr), Length:=Len(ntsstr)).Font
      .FontStyle = "Bold"
      .Color = vbRed
    End With
  End if
End With