Formato condicional

Hola navibel,

Prueba el codigo que te pongo a continuacion.

Saludos,
KL

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Respuesta As Integer, celda As Range
If Target.Count > 10000 Then
Respuesta = MsgBox("Ha cambiado mas de 10.000 celdas." _
& Chr(13) & "La aplicacion de los formatos puede" _
& Chr(13) & "tardar unos minutos. Desea continuar?", _
vbCritical + vbYesNo)
If Respuesta = vbNo Then Exit Sub
End If
For Each celda In Target
With celda.Interior
Select Case celda
Case "V"
.ColorIndex = 43
Case "PR"
.ColorIndex = 4
Case "R"
.ColorIndex = 3
Case "S"
.ColorIndex = 44
Case "E"
.ColorIndex = 50
Case Else
.ColorIndex = xlColorIndexNone
End Select
End With
Next celda
End Sub

Hola de nuevo,

Otra forma que podria ser un poco mas eficiente (aunque mas larga y no del todo testeada) si se tratase de rangos importantes a
cambiar.

Saludos,
KL

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Application.ScreenUpdating = False
Target.Interior.ColorIndex = xlColorIndexNone
If Target.Count = 1 Then
Set rng = Target
Else
On Error Resume Next
Set rng = Target.SpecialCells(xlCellTypeConstants, xlTextValues)
On Error GoTo 0
End If
If rng Is Nothing Then GoTo Salida
x = Application.CountA(rng)
If x <> rng.Count And x <> 0 Then
Dim Respuesta As Integer
Respuesta = MsgBox _
("El rango cambiado contiene mas de 8.192 rangos." & _
Chr(13) & "no adyacentes, por lo que no se podra usar el" & _
Chr(13) & "procedimiento rapido. El rango que se va a" & _
Chr(13) & "formatear es [" & rng.Address & "] y contiene " _
& Format(rng.Count, "#,##0") & Chr(13) & " celdas a escanear." & _
Chr(13) & Chr(13) & "Si decide continuar,el codigo puede tardar" & _
Chr(13) & "unos minutos segun la capacidad del PC." & _
Chr(13) & Chr(13) & "Desea continuar?", vbInformation + vbYesNo)
If Respuesta = vbNo Then GoTo Salida
End If
Dim celda As Range
For Each celda In rng
With celda.Interior
Select Case celda
Case "V"
.ColorIndex = 43
Case "PR"
.ColorIndex = 4
Case "R"
.ColorIndex = 3
Case "S"
.ColorIndex = 44
Case "E"
.ColorIndex = 50
End Select
End With
Next celda
Salida:
Application.ScreenUpdating = True
End Sub

Gracias KL, cualquiera de los dos funciona perfectamente. El fichero
solo lo componen dos hojas...De todas formas, esta macro desactiva el
deshacer¿Por qué...

Hola navibel,

Todos los macros que introducen cambios en la hoja (p.ej.: valores o formatos de celdas) borran las operaciones anteriores en la
lista de deshacer. El por que no lo se, me conformo con un "porque si" :-)

Saludos,
KL


"navibel" wrote in message news:
Gracias KL, cualquiera de los dos funciona perfectamente. El fichero
solo lo componen dos hojas...De todas formas, esta macro desactiva el
deshacer¿Por qué...