Results 1 to 4 of 4

Thread: VBA Formatting

  1. #1

    VBA Formatting



    Register for a FREE account, and/
    or Log in to avoid these ads!

    Hi All,

    I have this code that works great but works on the whole worksheet.

    Can this code be adapted to to use only on columns, C, E, G and H?

    Many thanks
    Craig


    Code:
    Private Sub Worksheet_Change(ByVal Target As Range)
     
    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 0.9 To 1
                    Cell.Interior.ColorIndex = 4
                    Cell.Font.Bold = True
                Case 0.8 To 0.89999999999999
                    Cell.Interior.ColorIndex = 36
                    Cell.Font.Bold = True
                Case 0.1 To 0.799999999999999
                    Cell.Interior.ColorIndex = 3
                    Cell.Font.Bold = True
                 Case 0
                    Cell.Interior.ColorIndex = 6
                    Cell.Font.Bold = True
                
                Case Else
                    Cell.Interior.ColorIndex = xlNone
                    Cell.Font.Bold = False
            End Select
        Next
     
    End Sub

  2. #2
    Administrator Ken Puls's Avatar
    Join Date
    Mar 2011
    Location
    Nanaimo, BC, Canada
    Posts
    2,268
    Articles
    57
    Blog Entries
    14
    Excel Version
    Excel Office 365 Insider
    Someone is probably going to post a more efficient way to do this, but this will work, and should be pretty easy for you to extend if you add more columns that are valid:

    Code:
    Private Sub Worksheet_Change(ByVal Target As Range)
     
    Dim Cell As Range
    Dim Rng1 As Range
        
        'Check for validity
        If Not Target.Columns.Count = 1 Then GoTo EarlyExit
        If Not Intersect(Target, ActiveSheet.Columns("C")) Is Nothing Then GoTo AllGood
        If Not Intersect(Target, ActiveSheet.Columns("E")) Is Nothing Then GoTo AllGood
        If Not Intersect(Target, ActiveSheet.Columns("H")) Is Nothing Then GoTo AllGood
        If Not Intersect(Target, ActiveSheet.Columns("G")) Is Nothing Then GoTo AllGood
        
        'All tests failed, so exit
        GoTo EarlyExit
        
    AllGood:
        'Looks like things are good, let's go!
        
        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 0.9 To 1
                    Cell.Interior.ColorIndex = 4
                    Cell.Font.Bold = True
                Case 0.8 To 0.89999999999999
                    Cell.Interior.ColorIndex = 36
                    Cell.Font.Bold = True
                Case 0.1 To 0.799999999999999
                    Cell.Interior.ColorIndex = 3
                    Cell.Font.Bold = True
                 Case 0
                    Cell.Interior.ColorIndex = 6
                    Cell.Font.Bold = True
                
                Case Else
                    Cell.Interior.ColorIndex = xlNone
                    Cell.Font.Bold = False
            End Select
        Next
    EarlyExit:
    End Sub
    Ken Puls, FCPA, FCMA, MS MVP

    Learn to Master Your Data at the Power Query Academy (the world's most comprehensive online Power Query training), with my book M is for Data Monkey, or our new Power Query Recipe cards!

    Main Site: http://www.excelguru.ca -||- Blog: http://www.excelguru.ca/blog -||- Forums: http://www.excelguru.ca/forums
    Check out the Excelguru Facebook Fan Page -||- Follow Me on Twitter

    If you've been given VBA code (a macro) for your solution, but don't know where to put it, CLICK HERE.

  3. #3
    Conjurer snb's Avatar
    Join Date
    May 2013
    Posts
    374
    Articles
    0
    Excel Version
    2020
    or:
    Code:
    Private Sub Worksheet_Change(ByVal Target As Range)
      on error resume next
      For Each cl In Intersect(UsedRange.SpecialCells(-4123, 1), Range("C1,E1,G1,H1").EntireColumn)
            cl.Interior.ColorIndex = xlNone
            If cl <= 1 Then cl.Interior.ColorIndex = Choose(1 + (10 * cl), 6, 3, 3, 3, 3, 3, 3, 3, 36, 4, 4)
            cl.Font.Bold = cl <= 1
       Next
    End Sub

  4. #4
    Administrator Ken Puls's Avatar
    Join Date
    Mar 2011
    Location
    Nanaimo, BC, Canada
    Posts
    2,268
    Articles
    57
    Blog Entries
    14
    Excel Version
    Excel Office 365 Insider
    Quote Originally Posted by Ken Puls View Post
    Someone is probably going to post a more efficient way to do this
    See what I mean? Nice work snb!
    Ken Puls, FCPA, FCMA, MS MVP

    Learn to Master Your Data at the Power Query Academy (the world's most comprehensive online Power Query training), with my book M is for Data Monkey, or our new Power Query Recipe cards!

    Main Site: http://www.excelguru.ca -||- Blog: http://www.excelguru.ca/blog -||- Forums: http://www.excelguru.ca/forums
    Check out the Excelguru Facebook Fan Page -||- Follow Me on Twitter

    If you've been given VBA code (a macro) for your solution, but don't know where to put it, CLICK HERE.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •