resaltar numeros en ambos cuadros

[dragonfire33]

Tengo el siguiente código y lo que hace es resaltar el último número agregado dividido entre las columnas ABCD en las casillas, pero solo resalta el rango "g3:m12" y me gustaría que ese mismo número se resaltara con color rojo en el rango "g16:m25" del libro de excel , pero para eso debo modificar gran parte del codigo como lo hago?

Sub Worksheet_Change privado (rango de destino byval)
Dim uF&, i&, nBusca%, Celda As Range
Si no intersect(target, columns(4)) no es nada entonces
Rango ("G3:G12,I3:I12,K3:K12,M3:M12"). Interior.Color = vbBlanco
Para i = 0 a 3
            nBusca = Target.Offset(0, i - 3)
Seleccionar Caso i
Caso 0
Set Celda = Rango("G3:G12"). Buscar(nBusca, , , xlWhole)
Caso 1
Set Celda = Rango("I3:I12"). Buscar(nBusca, , , xlWhole)
Caso 2
Set Celda = Rango("K3:K12"). Buscar(nBusca, , , xlWhole)
Caso 3
Establezca Celda = Rango("M3:M12"). Buscar(nBusca, , , xlWhole)
            
               
Finalizar selección
Si no celda no es nada entonces
                Celda.Interior.Color = vbRed
Fin si
Siguiente i
Rango ("G2"). Activar
Fin si
Fin sub
[/CÓDIGO]

 

[DanteAmor]

Prueba lo siguiente:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rng As Range, col As Range, Celda As Range
  Dim i&
  
  Set rng = Range("G3:G12,I3:I12,K3:K12,M3:M12, G16:G25,I16:I25,K16:K25,M16:M25")
  If Not Intersect(Target, Columns(4)) Is Nothing Then
    rng.Interior.Color = vbWhite
    For Each col In rng.Columns
      i = i + 1
      Set Celda = col.Find(Cells(Target.Row, i), , , xlWhole)
      If Not Celda Is Nothing Then
        Celda.Interior.Color = vbRed
      End If
      If i = 4 Then i = 0
    Next
    Range("G2").Activate
  End If
End Sub

 

[dragonfire33]

muchas gracias maestro dante

Prueba lo siguiente:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rng As Range, col As Range, Celda As Range
  Dim i&
 
  Set rng = Range("G3:G12,I3:I12,K3:K12,M3:M12, G16:G25,I16:I25,K16:K25,M16:M25")
  If Not Intersect(Target, Columns(4)) Is Nothing Then
    rng.Interior.Color = vbWhite
    For Each col In rng.Columns
      i = i + 1
      Set Celda = col.Find(Cells(Target.Row, i), , , xlWhole)
      If Not Celda Is Nothing Then
        Celda.Interior.Color = vbRed
      End If
      If i = 4 Then i = 0
    Next
    Range("G2").Activate
  End If
End Sub

muchas gracias eso era lo que estaba buscando

 

[DanteAmor]

Con todo gusto. Gracias por comentar.

 

[dragonfire33]

Con todo gusto. Gracias por comentar.

Dante la macro funciona excelente , pero necesito agregar esta línea a la macro call copiar ,que lo que hace es copiar consecutivamente los datos a la hoja2 después de ejecutar su código lo he hecho antes de end sub pero cada vez que se ejecuta envía a la hoja2 solo el cuadro de números de la parte derecha con el número ingresado en la primer columna , en este caso sería la columna A; la idea es que se ejecute call copy después de ingresar el último digito del número en mi caso la columna D gracias por todo

 

[DanteAmor]

Puedes poner aquí el código de tu macro "copiar"

 

[dragonfire33]

Sub zero()

Dim ultimaCeldaDatos As String

'hallar la ultima celda con datos de la columna B de la hoja estadistica
ultimaCeldaDatos = Sheets("hoja1").Cells(Rows.Count, 2).End(xlUp).Row
'copiando datos de columna B
Sheets("hoja1").Range("h2:o25").Copy

Sheets("hoja2").Select
'posicionando en la celda donde pegare los datos en la hoja hoja2
Sheets("hoja2").Cells(2, Columns.Count).End(xlToLeft).Offset(0, 2).Select
Selection.PasteSpecial
Application.CutCopyMode = False


'configurando el borde y tamaño de las columnas de Estadísticas Descriptivas
Selection.Borders.Weight = XlBorderWeight.xlThin
Selection.ColumnWidth = 6
Application.CutCopyMode = False

End Sub

 

[DanteAmor]

Supongo que la hoj1 es la que tiene el código con el evento Change.
Prueba así:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rng As Range, col As Range, Celda As Range
  Dim i&
  
  Set rng = Range("G3:G12,I3:I12,K3:K12,M3:M12, G16:G25,I16:I25,K16:K25,M16:M25")
  If Not Intersect(Target, Columns(4)) Is Nothing Then
    rng.Interior.Color = vbWhite
    For Each col In rng.Columns
      i = i + 1
      Set Celda = col.Find(Cells(Target.Row, i), , , xlWhole)
      If Not Celda Is Nothing Then
        Celda.Interior.Color = vbRed
      End If
      If i = 4 Then i = 0
    Next
    Range("G2").Activate
    call zero
  End If
End Sub

 

[dragonfire33]

Supongo que la hoj1 es la que tiene el código con el evento Change.
Prueba así:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rng As Range, col As Range, Celda As Range
  Dim i&
 
  Set rng = Range("G3:G12,I3:I12,K3:K12,M3:M12, G16:G25,I16:I25,K16:K25,M16:M25")
  If Not Intersect(Target, Columns(4)) Is Nothing Then
    rng.Interior.Color = vbWhite
    For Each col In rng.Columns
      i = i + 1
      Set Celda = col.Find(Cells(Target.Row, i), , , xlWhole)
      If Not Celda Is Nothing Then
        Celda.Interior.Color = vbRed
      End If
      If i = 4 Then i = 0
    Next
    Range("G2").Activate
    call zero
  End If
End Sub

maestro dante , tengo un problema con el codigo ,

Sheets("hoja2").Select
'posicionando en la celda donde pegare los datos en la hoja hoja2
Sheets("hoja2").Cells(2, Columns.Count).End(xlToLeft).Offset(0, 2).Select
Selection.PasteSpecial
Application.CutCopyMode = False

al pasar los datos por tercera vez me aparece error en selection.pastespecial

 

[DanteAmor]

Es un problema en tu macro. Es un tema diferente al título de este hilo.
Podrías crear un nuevo hilo, ahí describes cuál es el objetivo de tu macro, en qué línea aparece el error y qué dice el mensaje de error.