Change column content color based on value of "Severity" column

Your code wouldn't pass the compiler check, so I added variable declarations as necessary. I also reformatted it so I could follow the logic, and eliminated the ActiveSheet keywords in favor of a With block. I also changed your range definitions from using the very clumsy Range(Cells(xx, yy).Address & ":" & Cells(aa, bb).Address) to the more elegant Range(.Cells(xx, yy), .Cells(aa, bb))

When I tried running your code, I noticed that you defined r4 and myRange twice but r5 not at all. I eliminated the extra definitions for r4 and myRange, then added statements to add color to DNS Name column as initially requested.

Please triple check the results of the code after all these changes. I know the colors work as requested on worksheet NSOC Bulk Scans, but did not check any of the other actions in sub Calculate_Remediation_Plan.

Sub Calculate_Remediation_Plan()
Dim C As Range, myRange As Range, r As Range, r2 As Range, r3 As Range, r4 As Range, r5 As Range, r6 As Range, rList As Range
Dim i As Long, LColumn As Long, lcolumn2 As Long, lrow As Long
Dim wb As Workbook
Dim ws As Worksheet
Dim ws2 As String
Dim Lcol As Variant

Application.DisplayAlerts = False
Call Delete_column

On Error Resume Next
With ActiveSheet
    LColumn = .Cells(1, Columns.Count).End(xlToLeft).Column + 1
 
    With .ListObjects("MyTable")
        Set rList = .Range
        .Unlist
    End With

    ws2 = .Name

    lrow = .Cells(.Rows.Count, "G").End(xlUp).Row

    .Cells(1, LColumn).Value = "Remediation Timeline"
    'tp Cells(1, LColumn + 1).Value = "Target"
    .Cells(1, LColumn + 1).Value = "Remediation Plan"
    'tp Cells(1, LColumn + 2).Font.Bold = True
    
    Set r3 = .Range("1:1").Find(What:="Severity", LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
    'Set r5 = .Range("1:1").Find(What:="Risk", LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
    Set r4 = .Range("1:1").Find(What:="DNS Name", LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
    'Set r4 = .Range("1:1").Find(What:="Host", LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
    Set r6 = .Range("1:1").Find(What:="Solution", LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
    Set myRange = Range(.Cells(2, r3.Column), .Cells(lrow, r3.Column))
    'Set myRange = Range(.Cells(2, r5.Column), .Cells(lrow, r5.Column))
    
    Set r = .Range("1:1").Find(What:="Remediation Timeline", LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
    Set r2 = .Range("1:1").Find(What:="Remediation Plan", LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
    For Each C In myRange
        
        If C.Value = "High" Then
            .Cells(C.Row, r.Column).Value = "90 days"
            r4.Cells(C.Row).Interior.Color = vbBlue
            'Range("Q" & c.Row).Value = "90 days"
            'tp ActiveSheet.Range(Cells(C.Row, r2.Column).Address).Value = Date + 90
        End If
        
        If C.Value = "Medium" Then
            .Cells(C.Row, r.Column).Value = "120 days"
            r4.Cells(C.Row).Interior.Color = vbGreen
            'tp ActiveSheet.Range(Cells(C.Row, r2.Column).Address).Value = Date + 120
        End If
         
        If C.Value = "Low" Then
            .Cells(C.Row, r.Column).Value = "120 days"
            'tp ActiveSheet.Range(Cells(C.Row, r2.Column).Address).Value = Date + 120
        End If
          
        If C.Value = "Critical" Then
            .Cells(C.Row, r.Column).Value = "30 days"
            r4.Cells(C.Row).Interior.Color = vbRed
            'tp ActiveSheet.Range(Cells(C.Row, r2.Column).Address).Value = Date + 30
        End If
          
    Next
    
    With .Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range(.Cells(1, r4.Column), .Cells(lrow, r4.Column)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range(.Cells(1, r6.Column), .Cells(lrow, r6.Column)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range(.Cells(1, r3.Column), .Cells(lrow, r3.Column)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        
        .SetRange .UsedRange
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    If .AutoFilterMode = False Then
        .Range("A1").AutoFilter
        .ListObjects.Add(xlSrcRange, .UsedRange, , xlYes).Name = "MyTable"
    End If

    If InStr(1, ws.Cells(1, i).Value, "Column*", vbTextCompare) > 0 Then
        ws.Columns(i).EntireColumn.Delete
    End If
 
    .Cells.EntireColumn.AutoFit
    ActiveWindow.Zoom = 83
End With

On Error GoTo 0

Call Weblink
Sheets("Solutions").Move Before:=Sheets(1)

Worksheets(ws2).Select
      ActiveWorkbook.Save
'      ActiveWorkbook.Close

      Application.DisplayAlerts = True

      
End Sub

Select allOpen in new window

160325-Remediation-Plan-MacroQ28935.xlsb

Why do you need VBA for this when Conditional Formatting is sufficient and more efficient?

Conditional Formatting is automatic and does not require the user to enable macros.
The code will not work if the user's macro security level is set to High
You are using a Table so the conditional formatting will extend as data is added.

I would also use Data Validation for imputting the severity. This will eliminate users keying in the wrong term
160325-Remediation-Plan-Macro.xlsb

Thank you both bt and rc,

I am not sure which to pick.  When the rows are removed to re-run the macro, the coloring should disappear or otherwise be reset.

It would be better if the colors of the text could change instead of coloring the whole cell.  Thank you both again very much.

You can easily change the text colour instead of the background using conditional formatting.

If the severity is changed then the colour will change also.
160325-Remediation-Plan-Macro.xlsb

I changed the code so it would make the font change color rather than the highlighting. I also restored the font color to black before testing the severity level.

Sub Calculate_Remediation_Plan()
Dim C As Range, myRange As Range, r As Range, r2 As Range, r3 As Range, r4 As Range, r5 As Range, r6 As Range, rList As Range
Dim i As Long, LColumn As Long, lcolumn2 As Long, lrow As Long
Dim wb As Workbook
Dim ws As Worksheet
Dim ws2 As String
Dim Lcol As Variant

Application.DisplayAlerts = False
Call Delete_column

On Error Resume Next
With ActiveSheet
    LColumn = .Cells(1, Columns.Count).End(xlToLeft).Column + 1
 
    With .ListObjects("MyTable")
        Set rList = .Range
        .Unlist
    End With

    ws2 = .Name

    lrow = .Cells(.Rows.Count, "G").End(xlUp).Row

    .Cells(1, LColumn).Value = "Remediation Timeline"
    'tp Cells(1, LColumn + 1).Value = "Target"
    .Cells(1, LColumn + 1).Value = "Remediation Plan"
    'tp Cells(1, LColumn + 2).Font.Bold = True
    
    Set r3 = .Range("1:1").Find(What:="Severity", LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
    'Set r5 = .Range("1:1").Find(What:="Risk", LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
    Set r4 = .Range("1:1").Find(What:="DNS Name", LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
    'Set r4 = .Range("1:1").Find(What:="Host", LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
    Set r6 = .Range("1:1").Find(What:="Solution", LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
    Set myRange = Range(.Cells(2, r3.Column), .Cells(lrow, r3.Column))
    'Set myRange = Range(.Cells(2, r5.Column), .Cells(lrow, r5.Column))
    
    Set r = .Range("1:1").Find(What:="Remediation Timeline", LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
    Set r2 = .Range("1:1").Find(What:="Remediation Plan", LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
    myRange.Font.Color = 0
    For Each C In myRange
        
        If C.Value = "High" Then
            .Cells(C.Row, r.Column).Value = "90 days"
            r4.Cells(C.Row).Font.Color = vbBlue
            'Range("Q" & c.Row).Value = "90 days"
            'tp ActiveSheet.Range(Cells(C.Row, r2.Column).Address).Value = Date + 90
        End If
        
        If C.Value = "Medium" Then
            .Cells(C.Row, r.Column).Value = "120 days"
            r4.Cells(C.Row).Font.Color = vbGreen
            'tp ActiveSheet.Range(Cells(C.Row, r2.Column).Address).Value = Date + 120
        End If
         
        If C.Value = "Low" Then
            .Cells(C.Row, r.Column).Value = "120 days"
            'tp ActiveSheet.Range(Cells(C.Row, r2.Column).Address).Value = Date + 120
        End If
          
        If C.Value = "Critical" Then
            .Cells(C.Row, r.Column).Value = "30 days"
            r4.Cells(C.Row).Font.Color = vbRed
            'tp ActiveSheet.Range(Cells(C.Row, r2.Column).Address).Value = Date + 30
        End If
          
    Next
    
    With .Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range(.Cells(1, r4.Column), .Cells(lrow, r4.Column)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range(.Cells(1, r6.Column), .Cells(lrow, r6.Column)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range(.Cells(1, r3.Column), .Cells(lrow, r3.Column)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        
        .SetRange .UsedRange
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    If .AutoFilterMode = False Then
        .Range("A1").AutoFilter
        .ListObjects.Add(xlSrcRange, .UsedRange, , xlYes).Name = "MyTable"
    End If

    If InStr(1, ws.Cells(1, i).Value, "Column*", vbTextCompare) > 0 Then
        ws.Columns(i).EntireColumn.Delete
    End If
 
    .Cells.EntireColumn.AutoFit
    ActiveWindow.Zoom = 83
End With

On Error GoTo 0

Call Weblink
Sheets("Solutions").Move Before:=Sheets(1)

Worksheets(ws2).Select
      ActiveWorkbook.Save
'      ActiveWorkbook.Close

      Application.DisplayAlerts = True

      
End Sub

Select allOpen in new window

160325-Remediation-Plan-MacroQ28935.xlsb

BT, thank you.  The attached works differently than the code.

In the code for post #41523655, I get a run-time error on the Call Delete_column line.

The attached however, works flawlessly, but with one exception.  If you re-run the code, it does not remove and recreated the Remediation Timeline and Remediation Plan columns. I think the DNS entries are all working appropriately.

I revised the Delete_column sub as shown below so it deletes both the Remediation Timeline and Remediation Plan columns. It was previously deleting the Remediation Target column instead of Remediation Timeline. I also eliminated the .Find statement, and used an alternative means of finding the last column to avoid the run-time error.

It is worth noting that the previously attached workbook contained both Remediation Timeline & Remediation Timeline2 and Remediation Plan & Remediation Plan2 columns. Only the Remediation Plan2 column would have been deleted using the original code. I deleted both of the "2" columns from the attached workbook.

Private Sub Delete_column()
Dim ws As Worksheet
Dim i As Long, Lcol As Long

Set ws = ActiveSheet

Lcol = ws.UsedRange.Column + ws.UsedRange.Columns.Count - 1

If Lcol > 0 Then
    For i = Lcol To 1 Step -1
        'If InStr(1, ws.Cells(1, i).Value, "Remediation Target", vbTextCompare) > 0 Then     'Should this be Remediation Timeline?
        If InStr(1, ws.Cells(1, i).Value, "Remediation Timeline", vbTextCompare) > 0 Then
            ws.Columns(i).EntireColumn.Delete
        ElseIf InStr(1, ws.Cells(1, i).Value, "Remediation Plan", vbTextCompare) > 0 Then
            ws.Columns(i).EntireColumn.Delete
        End If
         
    Next i
End If
End Sub

Select allOpen in new window

160325-Remediation-Plan-MacroQ28935.xlsb

Excellent!  Thank you sir.  

For good measure, at the beginning of the macro run, each time, all fonts should be set to 'automatic', and fill should be set to 'no fill'.

If it's possible to remove references to other columns like "target" that we don't need anymore, that might be helpful.

I'm still not clear why you need a macro.

Thank you sir.

On one of our recent data sets, it appears that the two (2) columns "Remediation Timeline" and "Remediation Plan" are not being appended to the end and are instead inserted in the middle.  If possible, we should look for the end of the headers and ensure that those two columns always appear at the far right of the table. Further assistance with this is greatly appreciated.

Here is the follow-up question  https://www.experts-exchange.com/questions/28935921/Bug-fix-append-columns-to-end.html