0% found this document useful (0 votes)
18 views6 pages

Apont

fs

Uploaded by

ncardosolol
Copyright
© © All Rights Reserved
We take content rights seriously. If you suspect this is your content, claim it here.
Available Formats
Download as TXT, PDF, TXT or read online on Scribd
0% found this document useful (0 votes)
18 views6 pages

Apont

fs

Uploaded by

ncardosolol
Copyright
© © All Rights Reserved
We take content rights seriously. If you suspect this is your content, claim it here.
Available Formats
Download as TXT, PDF, TXT or read online on Scribd
You are on page 1/ 6

Option Explicit

Private VALUE_C() As String


Private VALUE_B() As String
Private VALUE_S() As String
Private VALUE_N() As String

Private Const COLOR_RESET As Long = xlColorIndexNone


Private Const COLOR_YELLOW As Long = &H1C8FF ' Yellow for blanks
Private Const COLOR_SIM As Long = &H5FD200 ' Green for "Sim"
Private Const COLOR_NAO As Long = &H3232FF ' Red for "Não"

Private Sub Worksheet_Change(ByVal Target As Range)

Dim ws As Worksheet
Dim tbl As ListObject
Dim rng As Range
Dim tblRng1 As Range
Dim tblRng2 As Range
Dim cell As Range
Dim lastColumn As Long

On Error GoTo HandleError


Application.EnableEvents = False
Application.ScreenUpdating = False

' Using Split to initialize the array


VALUE_C = Split("c,cima", ",")
VALUE_B = Split("b,baixo", ",")
VALUE_S = Split("s,sim", ",")
VALUE_N = Split("n,nao,não", ",")

' Set the worksheet and table


Set ws = ThisWorkbook.Sheets("Folha")
Set tbl = ws.ListObjects("Tabela")

' Check if the table's DataBodyRange is valid


If tbl.DataBodyRange Is Nothing Then
GoTo CleanExit
End If

Set rng = tbl.DataBodyRange

Call ConditionalFormatting

' Define ranges for column changes


Set tblRng1 = Intersect(rng, ws.Range("J:K"))
Set tblRng2 = Intersect(rng, ws.Range("L:N"))

' Handle changes for J:K


If Not Intersect(Target, tblRng1) Is Nothing Then
For Each cell In Intersect(Target, tblRng1)
ResetCellFormatting cell ' Reset color and clear previous formats
If Not IsEmpty(cell.Value) Then
UpdateCellValue cell, LCase(Trim(cell.Value)), True ' Update with
Cima/Baixo
End If
Next cell
End If

' Clear and Add Conditional Formatting for L:N


Call AddCellConditionalFormatting(tblRng2)

' Handle changes for L:N


If Not Intersect(Target, tblRng2) Is Nothing Then
For Each cell In Intersect(Target, tblRng2)
ResetCellFormatting cell ' Reset color
If Not IsEmpty(cell.Value) Then
UpdateCellValue cell, LCase(Trim(cell.Value)), False ' Update with
Sim/Não
End If
Next cell
End If

' Autofit columns and rows


tbl.Range.Columns.AutoFit
tbl.Range.Rows.AutoFit

CleanExit:
Application.EnableEvents = True
Application.ScreenUpdating = True
Exit Sub

HandleError:
MsgBox "Error: " & Err.Description
Resume CleanExit

End Sub

Private Sub ConditionalFormatting()


Dim ws As Worksheet
Dim tbl As ListObject
Dim rng As Range
Dim tblFm As FormatCondition

' Set the worksheet and table


Set ws = ThisWorkbook.Sheets("Folha")
Set tbl = ws.ListObjects("Tabela")
Set rng = tbl.DataBodyRange

' Clear previous conditional formatting for the entire worksheet

' Call the subroutine to update formatting dynamically


Call UpdateHeaderFormatting

' Add conditional formatting for blank cells within the table
Set tblFm = rng.FormatConditions.Add(xlBlanksCondition)
tblFm.Interior.Color = COLOR_YELLOW ' Yellow for blanks
End Sub
Private Sub ResetCellFormatting(ByRef cell As Range)
cell.Interior.ColorIndex = COLOR_RESET
End Sub

Private Sub UpdateCellValue(ByRef cell As Range, ByVal inputValue As String, ByVal


isJorK As Boolean)

inputValue = LCase(Trim(cell.Value))

Select Case isJorK

' Handle values for columns J and K


Case True
Select Case inputValue
Case "c", "cima"
cell.Value = "Cima"
Case "b", "baixo"
cell.Value = "Baixo"
Case Else
cell.Value = "" ' Clear cell if input is not valid
End Select
Case False
' Use Select Case to handle values for columns L and N
Select Case inputValue
Case "s", "sim"
cell.Value = "Sim"
Case "n", "nao", "não"
cell.Value = "Não"
Case Else
cell.Value = "" ' Clear cell if input is not valid
End Select
End Select
End Sub

Private Sub AddCellConditionalFormatting(tblRng2 As Range)


Dim conditionSim As FormatCondition
Dim conditionNao As FormatCondition

' Add conditional formatting for "Sim"


Set conditionSim = tblRng2.FormatConditions.Add(xlCellValue, xlEqual,
"=""Sim""")
conditionSim.Interior.Color = COLOR_SIM

' Add conditional formatting for "Não"


Set conditionNao = tblRng2.FormatConditions.Add(xlCellValue, xlEqual,
"=""Não""")
conditionNao.Interior.Color = COLOR_NAO
End Sub

Private Sub UpdateHeaderFormatting()


Dim lastColumn As Integer
Dim headerRange As Range
Dim headerColor As Long
Dim ws As Worksheet
Dim tableRow As Integer
Dim tbl As ListObject ' Define the table object
' Assuming ws and tbl are already defined elsewhere
Set ws = ThisWorkbook.Worksheets("Folha") ' Adjust the sheet name as needed
Set tbl = ws.ListObjects("Tabela") ' Adjust the table name as needed

tableRow = tbl.Range.Row ' Get the starting row of the table


lastColumn = tbl.ListColumns.Count ' Get the number of columns in the table

' Define the range for the row above the table (dynamic row based on table's
starting row)
If tableRow > 1 Then ' Ensure there's a row above the table to format
Set headerRange = ws.Range(ws.Cells(tableRow - 1, 1), ws.Cells(tableRow -
1, lastColumn))

' Set the header fill color (using defined color)


headerColor = 12611584 ' Custom header color

' Reset the worksheet cells' background color (if needed)


ws.Cells.FormatConditions.Delete

ws.Rows(1).Interior.Color = RGB(255, 255, 255)


ws.Rows(2).ClearFormats
With ws.Rows(2).Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(217, 217, 217)
End With

' Reapply the horizontal alignment for the dynamic range


With headerRange

.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlCenter

' Apply font settings


With .Font
.Name = "Calibri"
.Bold = True
.Size = 14
.Color = RGB(255, 255, 255)
End With

' Apply interior settings (fill color)


With .Interior
.Color = headerColor
End With

'Apply border settings


With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThick
.Color = RGB(9, 68, 155)
End With

With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThick
.Color = RGB(9, 68, 155)
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThick
.Color = RGB(9, 68, 155)
End With

End With
Else
MsgBox "No row above the table to format."
End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)


Dim ws As Worksheet
Dim tbl As ListObject
Dim rng As Range
Dim tblFm As FormatCondition
Dim tblRange As Range
Dim selectedRow As Range
Dim tblRng2 As Range

' Set the worksheet and the table


Set ws = Me ' Refers to the worksheet where this code is added
Set tbl = ws.ListObjects("Tabela")

' Get the table's range (including header and body, but excluding totals)
Set tblRange = tbl.Range
Set rng = tbl.DataBodyRange

Set tblRng2 = Intersect(rng, ws.Range("L:N"))

' Check if the selected cell is within the table


If Not Intersect(Target, tblRange) Is Nothing Then

' Remove any existing highlights in the table (clear conditional formatting
or background color)
tblRange.Interior.ColorIndex = xlNone
tblRange.Font.Color = RGB(0, 0, 0)
Call AddCellConditionalFormatting(tblRng2)

Set tblFm = rng.FormatConditions.Add(xlBlanksCondition)


tblFm.Interior.Color = COLOR_YELLOW

' Highlight the entire row for the selected cell if within the table's body
range
If Not Intersect(Target, tbl.DataBodyRange) Is Nothing Then
Set selectedRow = tbl.ListRows(Target.Row - tbl.DataBodyRange.Cells(1,
1).Row + 1).Range

selectedRow.FormatConditions.Delete

selectedRow.Interior.Color = 12611584
selectedRow.Font.Color = RGB(255, 255, 255)
End If
Else
' Clear formatting if the selection is outside the table
tblRange.Interior.ColorIndex = xlNone
tblRange.Font.Color = RGB(0, 0, 0)
Call AddCellConditionalFormatting(tblRng2)
End If
End Sub

You might also like