reducir codigo para resaltar celdas de una hoja a otra con condicion
publicado
como puedo mejorar este codigo byfejoal para que realice la condicion de resaltar las celdas azules que estan cerca a la celda de borde a una distancia de 21 celdas anterior y porterior a la celda de borde
el codigo realiza ese proceso pero me gustaria que el codigo fuera un poco mas reducido y ademas tengo problema con esta linea del codigo sub color
Sub color() Worksheets("hoja2").Range("b2:ac33").Interior.color = xlNone
Set ha = Worksheets("hoja2").Range("b2:ac33")
Set hn = Worksheets("hoja1").Range("a1:cy42") 'controlar rango
For i = 1 To hn.Cells.Count
'si la columna es par se omite
If hn.Cells(i).Column Mod 2 = 0 Then GoTo SALIDA
numero = hn.Cells(i)
cuenta = WorksheetFunction.CountIf(ha, numero)
If cuenta > 0 Then
For j = 1 To cuenta
If j = 1 Then Set busca = ha.Find(numero)
If j > 1 Then Set busca = ha.FindNext(busca)
On Error Resume Next 'si no se encuentra busca se omite el error
Celda = busca.Address
If Worksheets("hoja2").Range(Celda).Interior.ColorIndex = xlNone Then
Worksheets("hoja2").Range(Celda).Interior.ColorIndex = 6
End If
Next j
End If
SALIDA:
Next i
End Sub
les agradezco la colaboracion si alguien me puede ayudar a resolverlo
como puedo mejorar este codigo byfejoal para que realice la condicion de resaltar las celdas azules que estan cerca a la celda de borde a una distancia de 21 celdas anterior y porterior a la celda de borde
el codigo realiza ese proceso pero me gustaria que el codigo fuera un poco mas reducido y ademas tengo problema con esta linea del codigo sub color
Sub color()
Worksheets("hoja2").Range("b2:ac33").Interior.color = xlNone
Set ha = Worksheets("hoja2").Range("b2:ac33")
Set hn = Worksheets("hoja1").Range("a1:cy42") 'controlar rango
For i = 1 To hn.Cells.Count
'si la columna es par se omite
If hn.Cells(i).Column Mod 2 = 0 Then GoTo SALIDA
numero = hn.Cells(i)
cuenta = WorksheetFunction.CountIf(ha, numero)
If cuenta > 0 Then
For j = 1 To cuenta
If j = 1 Then Set busca = ha.Find(numero)
If j > 1 Then Set busca = ha.FindNext(busca)
On Error Resume Next 'si no se encuentra busca se omite el error
Celda = busca.Address
If Worksheets("hoja2").Range(Celda).Interior.ColorIndex = xlNone Then
Worksheets("hoja2").Range(Celda).Interior.ColorIndex = 6
End If
Next j
End If
SALIDA:
Next i
End Sub
les agradezco la colaboracion si alguien me puede ayudar a resolverlo
BuscarHoja2.xlsm