Bordear celdas coincidentes en ambas hojas
Como puedo ejecutar este código y que en la segunda hoja me bordee los mismos datos que están en la columna "o" de la primer hoja
Sub buscar_reemplazar_BORDE()
Application.ScreenUpdating = False
Dim lookup
'opcional: quitar bordes anteriores
Set DATOS = Range("AF1:AJ42").CurrentRegion
DATOS.Borders.LineStyle = xlNone
'se toma la selección desde el rango AI
lookup = ActiveCell.Value
'se guarda en AK1 ... ya tiene color y formato la celda
ActiveCell.Copy
Range("H1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
'preparar col AR con lista de rango AM:AP
With Range("O:O")
.ClearContents
.NumberFormat = "@"
End With
x = Range("J" & Rows.Count).End(xlUp).Row
finy = 2
For Z = 1 To x
nrox = Format(Range("J" & Z) & Range("K" & Z) & Range("L" & Z) & Range("M" & Z), "0000")
If InStr(1, UCase(nrox), "X", 0) = 0 Then
Range("O" & finy) = nrox: finy = finy + 1
End If
Next Z
Set DATOS = Range("AF1:AJ42").CurrentRegion
Set lista = Range("O1").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)
.BorderAround ColorIndex:=0, Weight:=xlThick
End With
Next j
Else
GoTo SIGUIENTE
End If
On Error GoTo 0
SIGUIENTE:
Next i
End With
SALIDA:
End Sub
1 Respuesta
Te anexo un nuevo código.
Revisa cómo estoy estableciendo en sh1 la hoja1 y en rng2 el rango de la hoja2. Más adelante, en la macro hago referencia a estos objetos. De esta manera puedes ejecutar la macro en cualquier hoja.
Sub buscar_reemplazar_BORDE()
'Por Dante Amor
Dim rng2 As Range, c As Range, f As Range
Dim nrox As String, cell As String
Dim sh1 As Worksheet
Dim i As Long
'
Set sh1 = Sheets("Hoja1")
Set rng2 = Sheets("Hoja2").Range("AF1:AJ42")
sh1.Range("O:O").ClearContents
sh1.Range("O:O").NumberFormat = "@"
'
For i = 1 To sh1.Range("J" & Rows.Count).End(xlUp).Row
nrox = Format(sh1.Range("J" & i) & sh1.Range("K" & i) & _
sh1.Range("L" & i) & sh1.Range("M" & i), "0000")
If InStr(1, nrox, "X", vbTextCompare) = 0 And nrox <> "" Then
sh1.Range("O" & Rows.Count).End(3)(2) = nrox
End If
Next
'
rng2.Borders.LineStyle = xlNone
For Each c In sh1.Range("O2", sh1.Range("O" & Rows.Count).End(xlUp))
Set f = rng2.Find(c.Value, , xlValues, xlWhole)
If Not f Is Nothing Then
cell = f.Address
Do
f.BorderAround ColorIndex:=0, Weight:=xlThick
Set f = rng2.FindNext(f)
Loop While Not f Is Nothing And f.Address <> cell
End If
Next
End SubPrueba y me comentas.
Hay algunas líneas de tu macro que no entiendo, ya que no tengo los datos para probar, pero si hay algo que no está funcionando, entonces explica con imágenes qué tienes y qué esperas de resultado.
¡Gracias! dante
Maestro ese código lo agregue a un formulario pero como puedo anexarle al código enviarlo a la hoja actual rango "A1"
No entiendo, explica los ejemplos de las imágenes.
