Otro vez macro formato condicional (color)

Apreciado amigo:
El pasado 16 de abril te hice una pregunta sobre el tem de referencia y obtuve tu rápida y brillante respuesta que, vuelvo a reproducir, más abajo.
Sin embargo, aplicando la macro que verás más abajo: consigo que me identifique los formatos condicionales de la selección efectuada pero me copia y pega la linea de esa celda aunque no se cumpla la condición impuesta en el formato condicional, porque me parece que lo único que hace la macro es identificar que a la celda se le ha asignado un formato condicional pero no verifica si se esta cumpliendo y -claro está- me pega todas las celdas, aunque no lo coumplan.
Espero haberme explicado con la suficiente claridad, ruego me contestes a la mayor brevedad (como es habitual en ti) dado que me urge mucho.
Una vez más, gracias.
HANS.
Aquí te pongo la macro:
Public Sub Copiarporcolorfondoformatocondicionalbuena()
'********En esta macro selecciona toda la fila y la copia en la hoja 2
Dim c As Range
Dim Co As Integer, y As Integer
For Each c In Selection
If c.Interior.ColorIndex = 3 Then
Co = Co + 1
c.EntireRow.Copy
Worksheets("Hoja2").Select
Worksheets("Hoja2").Cells(Co, 1).Select
Worksheets("Hoja2").Paste
ElseIf c.FormatConditions.Count > 0 Then
For y = 1 To c.FormatConditions.Count
If c.FormatConditions(y).Interior.ColorIndex = 3 Then
Co = Co + 1
c.EntireRow.Copy
Worksheets("Hoja2").Select
Worksheets("Hoja2").Cells(Co, 1).Select
Worksheets("Hoja2").Paste
Exit For
End If
Next
End If
Next c
End Sub
1

1 respuesta

Respuesta
1
Parece que no era tan fácil.
Tenés razón, considera Verdadera la condición siempre.
Agregué una comparación de condiciones y puse algunas sentencias en procedimientos para tratar de hacerlo más legible.
Public Sub Copiarporcolorfondoformatocondicionalbuena()
'********En esta macro selecciona toda la fila y la copia en la hoja 2
Dim c As Range
Dim Co As Integer, y As Integer
Dim resp As Boolean
For Each c In Selection
If c.Interior.ColorIndex = 3 Then
Co = Co + 1
Call pega_celdas(c.Worksheet.Name, c.Address, "Hoja2", Co)
ElseIf c.FormatConditions.Count > 0 Then
For y = 1 To c.FormatConditions.Count
If c.FormatConditions(y).Interior.ColorIndex = 3 Then
If (c.FormatConditions(y).Operator = xlBetween Or c.FormatConditions(y).Operator = xlNotBetween) Then
resp = CumpleCondicion(c.Worksheet.Name, c.Address, c.FormatConditions(y).Operator, c.FormatConditions(y).Formula1, c.FormatConditions(y).Formula2)
Else
resp = CumpleCondicion(c.Worksheet.Name, c.Address, c.FormatConditions(y).Operator, c.FormatConditions(y).Formula1, 0)
End If
If resp = True Then
Co = Co + 1
Call pega_celdas(c.Worksheet.Name, c.Address, "Hoja2", Co)
Exit For
End If '** resp
End If '** c.formatcond
Next '** y
End If '** c.interior.colorindex
Next c
End Sub
'****************
Sub pega_celdas(hoja1 As String, celda As String, hoja2 As String, Nrocelda2 As Integer)
Sheets(hoja1).Range(celda).EntireRow.Copy
Worksheets(hoja2).Select
Worksheets(hoja2).Cells(Nrocelda2, 1).Select
Worksheets(hoja2).Paste
End Sub
'****************
Function CumpleCondicion(hoja1 As String, celda As String, op As Integer, f1 As Integer, f2 As Integer) As Boolean
CumpleCondicion = False
Select Case op
Case xlBetween: If Worksheets(hoja1).Range(celda).Value >= f1 And Worksheets(hoja1).Range(celda).Value >= f2 Then CumpleCondicion = True
Case xlNotBetween: If Not (Worksheets(hoja1).Range(celda).Value >= f1 And Worksheets(hoja1).Range(celda).Value >= f2) Then CumpleCondicion = True
Case xlEqual: If Worksheets(hoja1).Range(celda).Value = f1 Then CumpleCondicion = True
Case xlNotEqual: If Not (Worksheets(hoja1).Range(celda).Value = f1) Then CumpleCondicion = True
Case xlGreater: If Worksheets(hoja1).Range(celda).Value > f1 Then CumpleCondicion = True
Case xlLess: If Worksheets(hoja1).Range(celda).Value < f1 Then CumpleCondicion = True
Case xlGreaterEqual: If Worksheets(hoja1).Range(celda).Value >= f1 Then CumpleCondicion = True
Case xlLessEqual: If Worksheets(hoja1).Range(celda).Value <= f1 Then CumpleCondicion = True
End Select
End Function
Lo probé y funciona.
Suerte.
Apreciado amigo:
Gracias por tu esfuerzo y rapidez.
He intentado ejecutar lo que me has enviado y me dice:
Se ha producido el error "13" en tiempo de ejecución:
No coinciden los tipos.
Cuando depuro, aparece resaltada en amarillo la "frase" siguiente:
resp = CumpleCondicion(c.Worksheet.Name, c.Address, c.FormatConditions(y).Operator, c.FormatConditions(y).Formula1, 0)
Te reproduzo la macro hasta esa línea para que te sea fácil localizarla (como verás, a la macro le cambié el nombre):
Public Sub CopiarporcolorfondoformatocondicionalFINALcumplecondicion()
'********En esta macro selecciona toda la fila y la copia en la hoja 2
Dim c As Range
Dim Co As Integer, y As Integer
Dim resp As Boolean
For Each c In Selection
If c.Interior.ColorIndex = 3 Then
Co = Co + 1
Call pega_celdas(c.Worksheet.Name, c.Address, "Hoja2", Co)
ElseIf c.FormatConditions.Count > 0 Then
For y = 1 To c.FormatConditions.Count
If c.FormatConditions(y).Interior.ColorIndex = 3 Then
If (c.FormatConditions(y).Operator = xlBetween Or c.FormatConditions(y).Operator = xlNotBetween) Then
resp = CumpleCondicion(c.Worksheet.Name, c.Address, c.FormatConditions(y).Operator, c.FormatConditions(y).Formula1, c.FormatConditions(y).Formula2)
Else
resp = CumpleCondicion(c.Worksheet.Name, c.Address, c.FormatConditions(y).Operator, c.FormatConditions(y).Formula1, 0)
Seguro que se trata de una tontería, pero soy incapaz de determinar qué es lo que estoy haciendo mal.
Una vez más: HELP, MY FRIEND!
Un abrazo,
Hans.
Hans :
Volqué el código que te había remitido antes en una nueva planilla . Puse algunas celdas en la hoja1 con el Color 3 (Colorado) y un formato condicional (si el contenido de la celdas es mayor a 5, pone color 3) y funciono sin errores.
¿Cuál es tu condición para el Formato Condicional?.
Uso Excel 97 (Office 97) sobre Windows 98.
Mi dirección de e-mail es [email protected]
¿Podrías mandarme el archivo -o parte del mismo- zipeado? .
Quiero ver si es un problema de versión .
El problema de "tipo" era porque la función "CumpleCondicion" esperaba un entero y no una cadena ( por Fórmula con referencia a otra celda).
Tuve que ajustar la función a esta circunstancia, usando una variable intemedia.
Pero además, parece que el "Each Cell" no quiere trabajar como corresponde con FormatConditions (y fórmula) porque se queda haciendo referencia a celda de la primer celda del rango. Ej si el rango es a10.. a20, la condición apunta a B10 siempre.
Eso me hizo tomar una decisión. Cambiar FOR EACH por 2 FOR NEXT.
Quedó así :
Public Sub CopiarporcolorfondoformatocondicionalFINALcumplecondicion()
'********En esta macro selecciona toda la fila y la copia en la hoja 2
Dim Co As Integer, y As Integer
Dim resp As Boolean
Dim fila1 As Long, fila2 As Long, fila As Long
Dim colu1 As Integer, colu2 As Integer, colu As Integer
Dim CHcolu As String
Dim hoja1 As String
fila1 = Selection.Cells(1).Row
fila2 = Selection.Cells(Selection.Count).Row
colu1 = Selection.Cells(1).Column
colu2 = Selection.Cells(Selection.Count).Column
hoja1 = Selection.Worksheet.Name
For colu = colu1 To colu2
CHcolu = Chr(64 + colu)
For fila = fila1 To fila2
Range(CHcolu & fila).Select
If ActiveCell.Interior.ColorIndex = 3 Then
Co = Co + 1
Call pega_celdas(ActiveCell.Worksheet.Name, ActiveCell.Address, "Hoja2", Co)
ElseIf ActiveCell.FormatConditions.Count > 0 Then
For y = 1 To ActiveCell.FormatConditions.Count
If ActiveCell.FormatConditions(y).Interior.ColorIndex = 3 Then
If (ActiveCell.FormatConditions(y).Operator = xlBetween Or ActiveCell.FormatConditions(y).Operator = xlNotBetween) Then
resp = CumpleCondicion(ActiveCell.Worksheet.Name, ActiveCell.Address, ActiveCell.FormatConditions(y).Operator, ActiveCell.FormatConditions(y).Formula1, ActiveCell.FormatConditions(y).Formula2)
Else
resp = CumpleCondicion(ActiveCell.Worksheet.Name, ActiveCell.Address, ActiveCell.FormatConditions(y).Operator, ActiveCell.FormatConditions(y).Formula1, "0")
End If
If resp = True Then
Co = Co + 1
Call pega_celdas(ActiveCell.Worksheet.Name, ActiveCell.Address, "Hoja2", Co)
' Exit For
End If '** resp
End If '** c.formatcond
Next '** y
End If '** c.interior.colorindex
Next fila
Next colu
End Sub
'****************
Sub pega_celdas(hoja1 As String, celda As String, hoja2 As String, Nrocelda2 As Integer)
Sheets(hoja1).Range(celda).EntireRow.Copy
Worksheets(hoja2).Select
Worksheets(hoja2).Cells(Nrocelda2, 1).Select
Worksheets(hoja2).Paste
Worksheets(hoja1).Select
End Sub
'****************
Function CumpleCondicion(hoja1 As String, celda As String, op As Integer, f1 As String, f2 As String) As Boolean
Dim F1BIS
F1BIS = Worksheets(hoja1).Range(Right(f1, Len(f1) - 1)).Value
CumpleCondicion = False
Select Case op
Case xlBetween: If Worksheets(hoja1).Range(celda).Value >= F1BIS And Worksheets(hoja1).Range(celda).Value >= f2 Then CumpleCondicion = True
Case xlNotBetween: If Not (Worksheets(hoja1).Range(celda).Value >= F1BIS And Worksheets(hoja1).Range(celda).Value >= f2) Then CumpleCondicion = True
Case xlEqual: If Worksheets(hoja1).Range(celda).Value = F1BIS Then CumpleCondicion = True
Case xlNotEqual: If Not (Worksheets(hoja1).Range(celda).Value = F1BIS) Then CumpleCondicion = True
Case xlGreater: If Worksheets(hoja1).Range(celda).Value > F1BIS Then CumpleCondicion = True
Case xlLess: If Worksheets(hoja1).Range(celda).Value < F1BIS Then CumpleCondicion = True
Case xlGreaterEqual: If Worksheets(hoja1).Range(celda).Value >= F1BIS Then CumpleCondicion = True
Case xlLessEqual: If Worksheets(hoja1).Range(celda).Value <= F1BIS Then CumpleCondicion = True
End Select
End Function
Parecía que iba a ser más simple ¿no?.
Suerte.
Federico:
Muchas gracias de nuevo: cada día demuestras tu buen saber hacer y tu alto grado de profesionalidad y compromiso.
Ha funcionado a las mil maravillas: yo también creí que sería más fácil, me has dado una lección magistral.
Un abrazo,
Hans.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas