Search code examples
excelvbaconditional-formatting

Excel conditional formating. Maybe with VBA script?

I would like to create a conditional formating. Attached picture for example. So If there is a value in a merged cell I would like to apply some formatting to the cell and two other cell below. There is 4 type of value Onsite,Home,Holiday,Not Available. How can I do it with conditional formatting or VBA script? enter image description here

Thanks

Solution

  • Okay so found the answare. I used VBA script for it. I use 3 script to be precise. One for create custom styles.

    Sub f_isStyleExists(stylName As String)

    Dim styl As Style

    On Error Resume Next
    Set styl = ActiveWorkbook.Styles(stylName)

    If Err.Number = 0 Then styl.Delete
End Sub

Sub Delete()
f_isStyleExists ("Smart Office")
End Sub

Sub Create_Styles()
Delete
With ActiveWorkbook.Styles.Add("Smart Office")
 .IncludeNumber = False
 .IncludeFont = True
 .IncludeAlignment = True
 .IncludeBorder = False
 .IncludePatterns = True
 .IncludeProtection = False
 .Font.Name = "Arial"
 .Font.Size = 12
 .Font.Color = vbBlack
 .Interior.Color = RGB(198, 224, 180)
 .HorizontalAlignment = xlHAlignCenter
 .VerticalAlignment = xlVAlignCenter
End Wit
End Sub

    This delete than creates the custom styles for me. Run this on demand if I make changes on the code. Removed extre styles so the code stay sort.

    This will check the changed cell if the value is "Smart Office" or "ONSITE" etc. (removed extra lines too)

    Private Sub Worksheet_Change(ByVal Target As Range)
Dim x As Integer
Dim y As Integer
x = ActiveCell.Row
y = ActiveCell.Column

        If Worksheets("Sheet1").Cells(x, y).Value = "Smart Office" Then
           Worksheets("Sheet1").Cells(x, y).Style = "Smart Office"
           Worksheets("Sheet1").Cells(x + 1, y).Style = "Smart Office"
           Worksheets("Sheet1").Cells(x, y + 1).Style = "Smart Office"
           Worksheets("Sheet1").Cells(x + 1, y + 1).Style = "Smart Office"
           Worksheets("Sheet1").Cells(x, y).NumberFormat = "@"
           Worksheets("Sheet1").Cells(x + 1, y).NumberFormat = "hh:mm"
           Worksheets("Sheet1").Range(Cells(x, y), Cells(x, y + 1)).HorizontalAlignment = xlCenterAcrossSelection
        ElseIf Worksheets("Sheet1").Cells(x, y).Value = "ONSITE" Then
           Worksheets("Sheet1").Cells(x, y).Style = "ONSITE"
           Worksheets("Sheet1").Cells(x + 1, y).Style = "ONSITE"
           Worksheets("Sheet1").Cells(x + 1, y + 1).Style = "ONSITE"
           Worksheets("Sheet1").Cells(x, y + 1).Style = "ONSITE"
           Worksheets("Sheet1").Cells(x, y).NumberFormat = "@"
           Worksheets("Sheet1").Cells(x + 1, y).NumberFormat = "hh:mm"
           Worksheets("Sheet1").Range(Cells(x, y), Cells(x, y + 1)).HorizontalAlignment = xlCenterAcrossSelection
        
        End If
            
End Sub

    Also I added a double for to recheck all the cells before save so it won't fail in special cases.

    Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim x As Integer
Dim y As Integer

'X is row Y is column

For x = 7 To 100 Step 2
    For y = 2 To 100 Step 2
        If Worksheets("Sheet1").Cells(x, y).Value = "Smart Office" Then
           Worksheets("Sheet1").Cells(x, y).Style = "Smart Office"
           Worksheets("Sheet1").Cells(x + 1, y).Style = "Smart Office"
           Worksheets("Sheet1").Cells(x, y + 1).Style = "Smart Office"
           Worksheets("Sheet1").Cells(x + 1, y + 1).Style = "Smart Office"
           Worksheets("Sheet1").Cells(x, y).NumberFormat = "@"
           Worksheets("Sheet1").Cells(x + 1, y).NumberFormat = "hh:mm"
           Worksheets("Sheet1").Range(Cells(x, y), Cells(x, y + 1)).HorizontalAlignment = xlCenterAcrossSelection
        ElseIf Worksheets("Sheet1").Cells(x, y).Value = "ONSITE" Then
           Worksheets("Sheet1").Cells(x, y).Style = "ONSITE"
           Worksheets("Sheet1").Cells(x + 1, y).Style = "ONSITE"
           Worksheets("Sheet1").Cells(x + 1, y + 1).Style = "ONSITE"
           Worksheets("Sheet1").Cells(x, y + 1).Style = "ONSITE"
           Worksheets("Sheet1").Cells(x, y).NumberFormat = "@"
           Worksheets("Sheet1").Cells(x + 1, y).NumberFormat = "hh:mm"
           Worksheets("Sheet1").Range(Cells(x, y), Cells(x, y + 1)).HorizontalAlignment = xlCenterAcrossSelection
        End If
    Next y
Next x
End Sub

    It is not perfect but working. I could seriously shorten the code with some function. Shared workbook is okay. Used centeracrossselection instead merged cells. Looks the same but not that buggy.