Vba conditional formatting

thedeadzeds

New member
Joined
Oct 25, 2011
Messages
37
Reaction score
0
Points
0
Excel Version(s)
2016
Hi All,

I've got this code which works great but It works for the whole spreadsheet. How to I adapt it to work for cells a13 to ho140

CHEERS


Code:
Option Compare Text 'A=a, B=b, ... Z=z
 
Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Range)
     If ActiveCell.Value = "Full Fail" Or ActiveCell.Value = "Sense Fail" Then
 
        MsgBox "Please ensure you complete 3 full audits", vbInformation, "Complete the reason for Fail - Right click and insert comment"
      End If
 
Dim Cell As Range
Dim Rng1 As Range
  
    On Error Resume Next
    Set Rng1 = ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas, 1)
    On Error GoTo 0
 
    If Rng1 Is Nothing Then
 
        Set Rng1 = Range(Target.Address)
    Else
 
        Set Rng1 = Union(Range(Target.Address), Rng1)
     End If
 
    For Each Cell In Rng1
 
        Select Case Cell.Value
 
             Case vbNullString
 
                 Cell.Interior.ColorIndex = xlNone
                  Cell.Font.Bold = False
 
             Case "Full Fail", "Sense Fail"
 
                 Cell.Interior.ColorIndex = 3
                  Cell.Font.Bold = True
 
             Case "Sense in progress", "Full in progress"
 
                 Cell.Interior.ColorIndex = 6
                  Cell.Font.Bold = True
 
             Case "Full Pass", "Sense Pass"
 
                 Cell.Interior.ColorIndex = 35
                  Cell.Font.Bold = True
 
             Case Else
 
                  Cell.Interior.ColorIndex = xlNone
                   Cell.Font.Bold = False
 
        End Select
      Next
  End Sub
 
Last edited by a moderator:
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cell As Range
Dim Rng1 As Range




    If Not Intersect(Target, Me.Range("A13:HO140")) Is Nothing Then
    
        If Target.Value = "Full Fail" Or Target.Value = "Sense Fail" Then
    
            MsgBox "Please ensure you complete 3 full audits", vbInformation, _
                   "Complete the reason for Fail - Right click and insert comment"
        End If


        On Error Resume Next
            Set Rng1 = Me.Cells.SpecialCells(xlCellTypeFormulas, 1)
        On Error GoTo 0


        If Rng1 Is Nothing Then


            Set Rng1 = Target
        Else


            Set Rng1 = Union(Target, Rng1)
        End If
            
        For Each Cell In Rng1
        
            Select Case Cell.Value
            
                Case vbNullString
                
                    Cell.Interior.ColorIndex = xlNone
                    Cell.Font.Bold = False
                
                Case "Full Fail", "Sense Fail"
                
                    Cell.Interior.ColorIndex = 3
                    Cell.Font.Bold = True
                
                Case "Sense in progress", "Full in progress"
                    
                    Cell.Interior.ColorIndex = 6
                    Cell.Font.Bold = True
                
                Case "Full Pass", "Sense Pass"
                
                    Cell.Interior.ColorIndex = 35
                    Cell.Font.Bold = True
                
                Case Else
                
                    Cell.Interior.ColorIndex = xlNone
                    Cell.Font.Bold = False
            End Select
        Next
    End If
End Sub
 
Works great thanks v much. Only issue is when I copy and paste or drag information I get a runtime 13 error
 
Back
Top