Aplicar formato a parte de una fila, dependiendo del valor de una celda
Necesito modificar el siguiente código para que, en vez de aplicar el formato a toda la fila, lo haga únicamente de la columna "A" a la "F".
El código que tendo es el siguiente.
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Application.ScreenUpdating = False
If Not Intersect(Target, Range("E:E")) Is Nothing Then
If (Target.Value = "Anulada") Then
With Target
.EntireRow.Interior.ColorIndex = 6
.EntireRow.Font.ColorIndex = 1
.EntireRow.Font.Bold = False
End With
End If
If (Target.Value = "En tramitación") Then
With Target
.EntireRow.Interior.ColorIndex = 0
.EntireRow.Font.ColorIndex = 1
End With
End If
If (Target.Value = "No aceptada") Then
With Target
.EntireRow.Interior.ColorIndex = 6
.EntireRow.Font.ColorIndex = 1
.EntireRow.Font.Bold = False
End With
End If
If (Target.Value = "Realizada") Then
With Target
.EntireRow.Interior.ColorIndex = 10
.EntireRow.Font.ColorIndex = 2
.EntireRow.Font.Bold = True
End With
End If
If (Target.Value = "Traspasada a RRII") Then
With Target
.EntireRow.Interior.ColorIndex = 11
.EntireRow.Font.ColorIndex = 2
.EntireRow.Font.Bold = True
End With
End If
End If
Application.ScreenUpdating = True
End Sub
2 Respuestas
.13.02.17
Buenas tardes,
Utiliza esta variante que, además, te permite modificar el rango de columnas que quieres afectar:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
INICol = "A" 'columna desde donde aplicar formato
FINCol = "F" 'columna hasta donde aplicar formato
'
ElRango = INICol & Target.Row & ":" & FINCol & Target.Row
If Not Intersect(Target, Range("E:E")) Is Nothing Then
With Range(ElRango)
Application.ScreenUpdating = False
If (Target.Value = "Anulada") Then
.Interior.ColorIndex = 6
.Font.ColorIndex = 1
.Font.Bold = False
End If
If (Target.Value = "En tramitación") Then
.Interior.ColorIndex = 0
.Font.ColorIndex = 1
End If
If (Target.Value = "No aceptada") Then
.Interior.ColorIndex = 6
.Font.ColorIndex = 1
.Font.Bold = False
End If
If (Target.Value = "Realizada") Then
.Interior.ColorIndex = 10
.Font.ColorIndex = 2
.Font.Bold = True
End If
If (Target.Value = "Traspasada a RRII") Then
.Interior.ColorIndex = 11
.Font.ColorIndex = 2
.Font.Bold = True
End If
Application.ScreenUpdating = True
End With
End If
End Sub
Bien, eso debería resolver lo que buscabas.
Pero quería proponerte esta alternativa que hace lo mismo pero reemplaza la secuencia de IFs por un SELECT Case:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
INICol = "A" 'columna desde donde aplicar formato
FINCol = "F" 'columna hasta donde aplicar formato
'
ElRango = INICol & Target.Row & ":" & FINCol & Target.Row
If Not Intersect(Target, Range("E:E")) Is Nothing Then
With Range(ElRango)
Application.ScreenUpdating = False
Select Case Target.Value
Case "Anulada"
.Interior.ColorIndex = 6
.Font.ColorIndex = 1
.Font.Bold = False
Case "En tramitación"
.Interior.ColorIndex = 0
Case "No aceptada"
.Interior.ColorIndex = 6
.Font.ColorIndex = 1
.Font.Bold = False
Case "Realizada"
.Interior.ColorIndex = 10
.Font.ColorIndex = 2
.Font.Bold = True
Case "Traspasada a RRII"
.Interior.ColorIndex = 11
.Font.ColorIndex = 2
.Font.Bold = True
End Select
Application.ScreenUpdating = True
End With
End If
End SubComo ves se simplificó bastante la redacción (y consecuentemente su eficiencia) pero cualquiera de ellas hacen lo que solicitaste.
Un abrazo
Fer
.
Disculpa, era un problema mío al copia y pegar: Funcional a la perfección.
Muchísimas Gracias.
Miguel A.
.
Perfecto, Miguel
Me alegro de que lo tengas resuelto.
Abrazo
Fer
.
H o l a : Te anexo la macro actualizada
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
'Act.Por.Dante Amor
Application.ScreenUpdating = False
If Not Intersect(Target, Range("E:E")) Is Nothing Then
Select Case Target.Value
Case "Anulada": windex = 6: wfont = 1: wbold = False
Case "En tramitación": windex = 0: wfont = 1: wbold = False
Case "No aceptada": windex = 6: wfont = 1: wbold = False
Case "Realizada": windex = 10: wfont = 2: wbold = True
Case "Traspasada a RRII": windex = 11: wfont = 2: wbold = True
End Select
With Range("A" & Target.Row & ":F" & Target.Row)
.Interior.ColorIndex = windex
.Font.ColorIndex = wfont
.Font.Bold = wbold
End With
End If
Application.ScreenUpdating = True
End Sub
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
Muchísimas gracias por vuestras rápidas respuestas. He probado vuestros códigos, en casa, en un excel 2016 y me da error siempre en:
.Interior.ColorIndex
El caso es que el código inicial me funcionaba en la oficina en excel 2003 y 2007; pero, en cambio, ahora tampoco mi código me funciona con este excel 2016 en casa.
Sabéis a qué puede deberse?
Disculpad, era un problema mío al copia y pegar: Funcional a la perfección.
Muchísimas Gracias.
Miguel A.
Puede ser la versión, prueba con la siguiente:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
'Act.Por.Dante Amor
Application.ScreenUpdating = False
If Not Intersect(Target, Range("E:E")) Is Nothing Then
Select Case Target.Value
Case "Anulada": windex = 65535: wfont = 1: wbold = False
Case "En tramitación": windex = xlNone: wfont = 1: wbold = False
Case "No aceptada": windex = 65535: wfont = 1: wbold = False
Case "Realizada": windex = 32768: wfont = vbWhite: wbold = True
Case "Traspasada a RRII": windex = 8388608: wfont = vbWhite: wbold = True
Case Else: windex = xlNone: wfont = 1: wbold = False
End Select
With Range("A" & Target.Row & ":F" & Target.Row)
'.Interior.ColorIndex = windex
'.Font.ColorIndex = wfont
.Interior.Color = windex
.Font.Color = wfont
.Font.Bold = wbold
End With
End If
Application.ScreenUpdating = True
End Sub
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias