Colorear celda si no contiene ninguno de los parámetros buscados
Tengo una macro que hace lo siguiente:
En la columna J tengo una serie de medicamentos que la macro (que copio más abajo) clasifica poniendo un "1" en la columna correspondiente (la clasificación de los medicamentos va desde la columna M hasta la U)...
Por ej, si se trata de un analgésico opiode, me lo pone en la columna M, si se trata de un coadyuvante en la T, etc.
Además me resalta la celda del medicamento en un color, si en el texto de esta celda hay alguna palabar como "retira", "quita".. Etc. (por ejemplo, si en la celda dice "se retira Paracetamol", este medicamento no se clasifica en ninguna columna, sino que sólo se colorea la celda).
También me resalta la celda del medicamente en otro color, si el texto que hay en ella no coincide con ningún parámetro de búsqueda.
El problema que me surje es que en los parámetros de búsqueda sólo están incluidos los medicamentos habituales y no todos los existentes, por lo tanto, me gustaría incluir en esta macro que si en la celda hay alguna palabra que no he indicado en la búsqueda, también me resalte la celda de otro color.
Por ejemplo, si en la celda dice "Tramadol, Gabapentina y Yantil", la macro me estará colocando un 1 en la columna de Tramadoles, otro 1 en la columna de co-analgésicos (Gabapentina), pero el Yantil me quedó sin clasificar porque no lo he incluido en los parámetros de búsqueda. Y como la macro "al menos encuentra una coincidencia", esta celda no está resaltada y la da como OK.
Espero que se haya entendido..
Copio la macro que tengo actualmente
Sub clasificar()
Dim Posicion As Integer
Dim I As Long
Dim ultima_fila As Long
Dim contar_carac As Integer
Range("a1").End(xlDown).Select
ultima_fila = ActiveCell.Row
Range("J2").Select
For I = 1 To ultima_fila
contar_carac = 0
If InStr(1, ActiveCell, "retira", vbTextCompare) <> 0 Or InStr(1, ActiveCell, "tolera", vbTextCompare) <> 0 Or _
InStr(1, ActiveCell, "quita", vbTextCompare) <> 0 Or InStr(1, ActiveCell, "inicia", vbTextCompare) <> 0 Or _
InStr(1, ActiveCell, "incia", vbTextCompare) <> 0 Or InStr(1, ActiveCell, "aumenta", vbTextCompare) <> 0 Then
ActiveCell.Interior.Color = RGB(20, 255, 255)
Else
Posicion = InStr(1, ActiveCell, "Tramadol", vbTextCompare)
If Posicion <> 0 Then
ActiveCell.Offset(0, 3) = 1
contar_carac = contar_carac + 1
End If
Posicion = InStr(1, ActiveCell, "Adolonta", vbTextCompare)
If Posicion <> 0 Then
ActiveCell.Offset(0, 3) = 1
contar_carac = contar_carac + 1
End If
//...Y ASÍ CON TODOS LOS NOMBRES DE LOS MEDICAMENTOS...//
If contar_carac = 0 Then
ActiveCell.Interior.Color = RGB(255, 25, 255)
End If
End If
ActiveCell.Offset(1, 0).Select
Next I
End Sub
1 Respuesta
H o l a:
Antes de comparar el medicamento, se tendría que separa el contenido de la celda.
Por ejemplo:
Si en la celda tienes:
"Tramadol, Gabapentina y Yantil"
Entonces se tiene que buscar "Tramadol" en los medicamentos, después se tiene que buscar "Gabapentina" y por último se tiene que buscar "Yantil", si alguno de los 3 no se encuentra, entonces se pintaría la celda.
Habría que modificar gran parte de tu macro.
Mejor envíame tu archivo con algunos datos y con la macro para optimizar el código y poder realizar las búsquedas por medicamento.
Analizo tu archivo y te envío la respuesta.
Mi correo [email protected]
En el asunto del correo escribe tu nombre de usuario “verew” y el título de esta pregunta.
:)
S a l u d o s . D a n t e A m o r
Buenos días Dante,
Muchas gracias por la respuesta! Tal como solicitado, ya te he enviado el archivo.
Un saludo
H o l a:
Te anexo el nuevo diseño de la macro, lo que ahora hace es separar el texto de la columna J en medicamentos, cada uno de los medicamentos es buscado en la hoja "Medicamentos", si lo encuentra lo clasifica, si no lo encuentra te lo pone en la columna "Z" para que sepas cuál es el medicamento que no encontró.
Es necesario que en la hoja "Medicamentos" pongas todos los medicamentos y su clasificación; antes tenías la clasificación dentro de la macro, lo cual resultaba un poco complejo, ya que es difícil saber si están todos los medicamentos y si la clasificación es correcta, en cambio en una hoja puedes tener una vista de esta forma:
Esta es la clasificación de los colores, puedes cambiar el número de color por el que desees.
Select Case cuenta Case -1 wcolor = 7 'Rosa. Sin clasificación Case 0 wcolor = 5 'Azul. Ningúm medicamento se encontró Case Is < tope wcolor = 4 'Verde. Faltan medicamentos Case Else wcolor = xlNone 'Sin color. Completo End Select
Otro de los cambios en la macro, al momento de clasificar el medicamento, estoy poniendo un contador, para saber si la clasificación tiene más de un medicamento.
Eso está en esta línea:
h1.Cells(i, b.Column + 12) = h1.Cells(i, b.Column + 12) + 1
Si quieres que solamente te aparezca un 1, entonces cambia la línea por esto:
h1.Cells(i, b.Column + 12) = 1
La macro completa:
Sub ClasificarMedicamentos()
'Por.Dante Amor
Application.ScreenUpdating = False
Application.StatusBar = False
Set h1 = Sheets("Trat_vb")
Set h2 = Sheets("Medicamentos")
'
u = h1.Range("J" & Rows.Count).End(xlUp).Row
h1.Range("M2:Z" & u).Clear
seps = Array(",", Chr(10), "/", " y ", "-", " ", "+")
canc = Array("retira", "tolera", "quita", "inicia", "incia", "aumenta")
For i = 2 To u
Application.StatusBar = "Procesando registro: " & i & " de: " & u
cuenta = 0
dato = WorksheetFunction.Trim(h1.Cells(i, "J"))
For m = LBound(canc) To UBound(canc)
If InStr(1, dato, canc(m)) > 0 Then
cuenta = -1
End If
Next
'
If cuenta = 0 Then
For j = LBound(seps) To UBound(seps)
dato = Replace(dato, seps(j), "|")
dato = WorksheetFunction.Trim(dato)
Next
meds = Split(dato, "|")
tope = UBound(meds) + 1
For k = LBound(meds) To UBound(meds)
palabra = WorksheetFunction.Trim(meds(k))
If palabra = "" Then
tope = tope - 1
Else
existe = False
pala2 = palabra
For n = 1 To 3
Set b = h2.UsedRange.Find(pala2, lookat:=xlWhole)
If Not b Is Nothing Then
cuenta = cuenta + 1
h1.Cells(i, b.Column + 12) = h1.Cells(i, b.Column + 12) + 1
existe = True
Exit For
End If
If Len(pala2) < 2 Then
Exit For
Else
pala2 = Left(pala2, Len(pala2) - 1)
End If
Next
If existe = False Then
h1.Cells(i, "Z") = h1.Cells(i, "Z") & "+" & palabra
End If
End If
Next
End If
'
Select Case cuenta
Case -1
wcolor = 7 'Rosa. Sin clasificación
Case 0
wcolor = 5 'Azul. Ningúm medicamento se encontró
Case Is < tope
wcolor = 4 'Verde. Faltan medicamentos
Case Else
wcolor = xlNone 'Sin color. Completo
End Select
'
h1.Cells(i, "J").Interior.ColorIndex = wcolor
Next
Application.ScreenUpdating = False
Application.StatusBar = False
MsgBox "Fin"
End SubNota: la macro demora algunos segundos, es por eso que en la parte inferior izquierda de excel (barra de estatus), estoy poniendo un contador, para que sepas cuál registro se está procesando.
:) S aludos. D a n t e A m o r. Recuerda valorar la respuesta. G r a c i a s ;)
