Make the font red if derate or - and green if uprate or +

[Nlhicks]

This code does what it is supposed to do such that it returns this:

What I want it to return is this:

Public Sub Bold_in_Concatenate1()
' https://www.mrexcel.com/board/threads/run-my-master-workbook-and-call-another-non-macro-enabled-workbook-and-do-the-edits-to-it-prior-to-saving.1223414/
' Updated: 20221202
' Reason:  Reworked Code
    Dim wbkData           As Workbook
    Dim wksWork           As Worksheet
    Dim blnEnd            As Boolean
    Dim lngTarget         As Long
    Dim wksWorkOn         As Worksheet
    Dim strWbVersion      As String
    Dim wbkTarget         As Workbook
    Dim wksFrom           As Worksheet
  

    Const cstrPath        As String = "C:\Users\nhicks\Documents\Ratings\Saved Versions\"
    Const cstrWbData      As String = "WAPA-UGPR Facility Rating and SOL Record (Master).xlsm"
    Const cstrShData      As String = "Line Update"

    Const cstrStFileName  As String = "WAPA-UGPR Facility Rating and SOL Record (Data File)_v"
    Const cstrShFacility  As String = "Facility Ratings & SOLs (Lines)"
    
        GetWorkbook_Worksheet cstrPath, cstrWbData, wbkData, cstrShData, wksWork

  If wbkData Is Nothing Then
    MsgBox "No Object set for '" & cstrWbData & "'. ", vbInformation, cstrMsgTitle
    blnEnd = True
    GoTo end_here
  End If
  If wksWork Is Nothing Then
    MsgBox "No Object set for '" & cstrShData & "'. ", vbInformation, cstrMsgTitle
    blnEnd = True
    GoTo end_here
  End If
  
  With wksWork
    'assuming that the cells are all located on the same sheet
    '??? Range("Q13") is used two-times ???
    .Range("D32").Value = ("(" & .Range("L11") & " " & .Range("K13") & " " & .Range("L13") & " " & .Range("Q13") & " " & _
        "," & " " & .Range("O11") & " " & .Range("N13") & " " & .Range("O13") & " " & .Range("Q13") & ")")
    .Range("D32").Font.Bold = True
    
  End With
  GetWorkbook_Worksheet cstrPath, strWbVersion, wbkTarget, cstrShFacility, wksWorkOn

'  With wksWorkOn
'    lngLastRow = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Cells(1).Row
'    wksFrom.Range("J13").Value = .Range("A2:A685").SpecialCells(xlCellTypeVisible).Value
'
'End With

end_here:
  Workbook_Worksheet2Nothing wbkData, wksWork
  If blnEnd Then End
  
Call Show_Update


End Sub

 

[Micron]

When you see references like .Value, they usually pertain to whatever is defined in a With block. Look at your code - .Value isn't a member of wksWork.
It is a member of a range or cell on wksWork though. Maybe it pertains to .Range("D33")? You have that error in several places, such as .Font
You could nest another With block inside the 1st one if that makes it easier. Then you can "drill" down to reference the correct range and deal with properties such as .Value and .Font in the same manner.

 

[Nlhicks]

 

[Nlhicks]

Sometimes my output will look like this:

 

[Micron]

Not sure if you tried HaHoBe's code. It uses the nested With that I mentioned. This is an odd scenario - perhaps he should get the credit for the solution, especially if it works.
Thanks.

 

[Nlhicks]

I gave HaHo a Checkmark and a heart

It does not work. However, I gave me an idea and I am trying to get it to work now.

Sometimes just all of your inputs gives me what I needed to figure it out. You all look at things a little bit differently than what I look at them like so when you put in your input it makes me start thinking about it differently and I can find solutions. Thank you all for all that you do, I would never get anything done with out your input. You all have saved my life more than once , Thank you.

 

[HaHoBe]

Hi Nicole,

my code based on the part of the code from the opening post. And there Range("D32") was mentioned so I built the sample around just that cell.

To really help you should specify

It does not work.

You have introduced a new range with Range("D33"). And here we are again without knowing how the concatened string from D32 gets wings to fly to D33.

I'm sure we can help but we would need some more information (what does not work, any errors showing up, no result in which cell) and on where the value in cell D33 comes from.

Holger

 

[Nlhicks]

Okay, let me try and break it down:

The Master Worksheet:

 

[Nlhicks]

The Concatenate function looks at the "Delta Value" Table and Concatenates the values in that table and places the concatenated value in Summary of Line Updates table at the bottom. Then when I hit Send Email it opens up an outlook email and copies the Summary of Line Updates into an email to send to a bunch of folks. Unfortunately, I colored the table this time and produced the email and the font was still black even though I color coded it in the table. I think I may need to make the code adjustment to the email version of the code. I will provide that in another window.

 

[Nlhicks]

Option Explicit
Sub CopyRows()
Dim i As Integer
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet6")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Sheet10")
    ws1.Range("B31:G37").Copy
    ws2.Range ("C31:J40") '<------------------------------------------------------- change range to be inserted here.
    Mail_Selection_Range_Outlook_Body
End Sub
Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range, Rng2 As Range
Dim OutApp As Object
Dim OutMail As Object
Dim lEndRow
Dim Value As String
Set rng = Nothing
Set Rng2 = Nothing

Dim SpanStyle As FormatColor

' Only send the visible cells in the selection.
Set rng = Sheets("Line Update").Range("B31:G37")
Set Rng2 = Sheets("Xfmr Update").Range("C31:J40") '<------------------------------------------------------- change range to be inserted here.
    If rng Is Nothing Then
            MsgBox "An unknown error has occurred. "
        Exit Sub
    End If
    If Rng2 Is Nothing Then
            MsgBox "An unknown error has occurred. "
        Exit Sub
    End If
    With Application
            .EnableEvents = False
            .ScreenUpdating = False
    End With
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
''''There is a section here that says To: a bunch of folks, CC: a bunch of folks and Subject: Update'''
 .HTMLBody = "<p style='font-family: Calibri; 11'>" & _
                "<p style='font-family: Calibri; 11'>" & "Greetings," & "<br><br>" & "</p>" & _
                "<p style='font-family: Calibri; 11'>" & "An update has been published to the WAPA-UGPR Facility Rating and SOL Record posted at:" & "<br><br>" & _
                "<p style='font-family: Calibri; 11'>" & "https://wapa.sharepoint.com/:x:/r/sites/UGPPowerSystemsOperations/b4400/_layouts/15/Doc.aspx?sourcedoc=%7B6B6173BE-9388-447C-90AA-A3DA547FABA1%7D&file=WAPA-UGPR%20Facility%20Rating%20and%20SOL%20Record%20-%20v1_150%20-%2011%20Oct%202022.xlsx&action=default&mobileredirect=true" & "<br><br>" & _
                "<p style='font-family: Calibri; 11'>" & "This is the updated data for your records:" & "<br><br>" & _
                "<p style='font-family: Calibri; 11'>" & "The following Xfmrs were updated:" & "<br><br>" & _
                "<p style='font-family: Calibri; 11'>" & RangetoHTML(rng) & "<br><br>" & _
                "<p style='font-family: Calibri; 11'>" & "The following Transformers were updated:" & "<br><br>" & _
                "<p style='font-family: Calibri; 11'>" & "All updated workbook rows are highlighted in BLUE for ease of filtering." & _
                "<p style='font-family: Calibri; 11'>" & "Please send any corrections or changes to UGP-BESRatings.gov, including any access challenges you experience with the link above. Thank you" & "<br><br>" & _
                "<p style='font-family: Calibri; 11'>" & "Warm Regards!!!!!" & "<br><br>" & _
'''There is a section here that contains email contact information it works so I will not include that'''

    .Display
End With
On Error GoTo 0
With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
    Dim FSO As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
   
    rng.Copy
    'rng2.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
       ' .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    'Read all data from the htm file into RangetoHTML
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set ts = FSO.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
    'Close TempWB
    TempWB.Close savechanges:=False
    'Delete the htm file we used in this function
    Kill TempFile
    Set ts = Nothing
    Set FSO = Nothing
    Set TempWB = Nothing
End Function

Function RangetoHTML_2(Rng2 As Range)
    Dim FSO As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
   
    Rng2.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
       ' .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    'Read all data from the htm file into RangetoHTML
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set ts = FSO.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML_2 = ts.ReadAll
    ts.Close
    RangetoHTML_2 = Replace(RangetoHTML_2, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
    'Close TempWB
    TempWB.Close savechanges:=False
    'Delete the htm file we used in this function
    Kill TempFile
    Set ts = Nothing
    Set FSO = Nothing
    Set TempWB = Nothing
End Function

 

[Nlhicks]

This is the email version of the code. It works quite well as is except I cannot get any color coding and the hyperlink does not work so I enter it manually after the fact. Everything else works like a champ. Oh yeah, I also have to manually enter the new version number in the subject and the body of the email since it does not do that automatically. That may be just too much to try and pack in this whole thing but it would be a really nice little detail to include so the user does not have to change it manually every time they want to use the template.