Colocar borde de celda dejando celdas de color amarillo intactas
Experta elsa la idea es como lo explico en el titulo pero de acuerdo a la lupa del formulario que se ejecute buscar-reemplazar-color pero con la opción de borde de celda y no con marcarlas de amarillo y claro eliminando el código de concidencias
1 respuesta
Para quitar bordes anteriores, se agrega debajo de la declaración del rango DATOS la línea en negrita:
Set DATOS = Range("A1:AA80").CurrentRegion
'EM: QUITAR BORDES ANTERIORES
DATOS.Borders.LineStyle = xlNone
Y en lugar de asignarle color amarillo quedará así formateando con bordes:
With Range(Celda)
'.Interior.ColorIndex = 6 'amarillo
.BorderAround ColorIndex:=0, Weight:=xlThick
'.Select
End With
Pero como tu libro tiene macros repetidas que copiaste de otros procesos, utilicé la del módulo UF. También el formulario Análisis para este caso tiene más ajustes. Te estoy devolviendo el libro con comentarios.
Sdos y no olvides valorar la consulta.
Experta elsa pero antes de ejecutar el código necesito pasar los números que están en la columna
"ad:ag" a la columna "ai" pero sin POR sin ejecutar buscar y reemplazar
Que hay que quitarle a este código para eso
Creo que solo es lo de negrita
Sub buscar_reemplazar_color()
'preparar col AP
With Range("AI:AI")
.ClearContents
.NumberFormat = "@"
End With
x = Range("AD" & Rows.Count).End(xlUp).Row
finy = 2
For Z = 2 To x
nrox = Format(Range("AD" & Z) & Range("AE" & Z) & Range("AF" & Z) & Range("AG" & Z), "0000")
If InStr(1, UCase(nrox), "X", 0) = 0 Then
Range("AI" & finy) = nrox: finy = finy + 1
End If
Next Z
Set DATOS = Range("F1:Y40").CurrentRegion
Set lista = Range("AI1").CurrentRegion
MATRIZ = DATOS
With lista
For i = 2 To .Rows.Count
numeros = .Cells(i, 1)
cuenta = WorksheetFunction.CountIf(DATOS, numeros)
If cuenta > 0 Then
For j = 1 To cuenta
If j = 1 Then Set busca = DATOS.Find(Format(numeros, "0000"), lookat:=xlWhole)
If j > 1 Then Set busca = DATOS.FindNext(busca)
On Error Resume Next
celda = busca.Address
With Range(celda)
.Interior.ColorIndex = 6 'amarillo
.Select
End With
Next j
Else
GoTo SIGUIENTE
End If
On Error GoTo 0
SIGUIENTE:
Next i
End With
SALIDA:
End Sub
Esa no es la macro ajustada, te comenté que es la del Mod_UF a la que le cambié el nombre porque tenías 2 con el mismo nombre:
Sub nvo_buscar_reemplazar_color()
'preparar col AP
With Range("AI:AI")
.ClearContents
.NumberFormat = "@"
End With
x = Range("AD" & Rows.Count).End(xlUp).Row
finy = 2
For Z = 2 To x
nrox = Format(Range("AD" & Z) & Range("AE" & Z) & Range("AF" & Z) & Range("AG" & Z), "0000")
If InStr(1, UCase(nrox), "X", 0) = 0 Then
Range("AI" & finy) = nrox: finy = finy + 1
End If
Next Z
Set DATOS = Range("A1:AA80").CurrentRegion
'EM: QUITAR BORDES ANTERIORES
DATOS.Borders.LineStyle = xlNone
Set lista = Range("AI1").CurrentRegion
MATRIZ = DATOS
With lista
For i = 2 To .Rows.Count
numeros = .Cells(i, 1)
cuenta = WorksheetFunction.CountIf(DATOS, numeros)
If cuenta > 0 Then
For j = 1 To cuenta
If j = 1 Then Set busca = DATOS.Find(Format(numeros, "0000"), lookat:=xlWhole)
If j > 1 Then Set busca = DATOS.FindNext(busca)
On Error Resume Next
Celda = busca.Address
With Range(Celda)
'.Interior.ColorIndex = 6 'amarillo
.BorderAround ColorIndex:=0, Weight:=xlThick
'.Select
End With
Next j
Else
GoTo SIGUIENTE
End If
On Error GoTo 0
SIGUIENTE:
Next i
End With
SALIDA:
'10-08: 'ya se tiene lista en col AP sin duplicados ni X. Se colorea hoja Pista
'Call buscaCuadro ----EM: EVALUAR SI DEBE EJECUTAR O NO
End SubAl final de todo, inhabilité la que se llama buscaCuadro... evaluá si esa se debe ejecutar o no.
Sdos!
