resaltar numeros en ambos cuadros

dragonfire33

New Member
Joined
Oct 7, 2021
Messages
27
Office Version
  1. 365
Platform
  1. Windows
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?
VBA Code:
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]
 

Attachments

  • 22.png
    22.png
    128.9 KB · Views: 4

Excel Facts

Best way to learn Power Query?
Read M is for (Data) Monkey book by Ken Puls and Miguel Escobar. It is the complete guide to Power Query.

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,770
Office Version
  1. 2007
Platform
  1. Windows
Prueba lo siguiente:

VBA Code:
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

New Member
Joined
Oct 7, 2021
Messages
27
Office Version
  1. 365
Platform
  1. Windows
muchas gracias maestro dante
Prueba lo siguiente:

VBA Code:
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

Well-known Member
Joined
Dec 3, 2018
Messages
13,770
Office Version
  1. 2007
Platform
  1. Windows
Con todo gusto. Gracias por comentar.
 

dragonfire33

New Member
Joined
Oct 7, 2021
Messages
27
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

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

Well-known Member
Joined
Dec 3, 2018
Messages
13,770
Office Version
  1. 2007
Platform
  1. Windows
Puedes poner aquí el código de tu macro "copiar"
 

dragonfire33

New Member
Joined
Oct 7, 2021
Messages
27
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

VBA Code:
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

Well-known Member
Joined
Dec 3, 2018
Messages
13,770
Office Version
  1. 2007
Platform
  1. Windows
Supongo que la hoj1 es la que tiene el código con el evento Change.
Prueba así:

VBA Code:
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
 
Solution

dragonfire33

New Member
Joined
Oct 7, 2021
Messages
27
Office Version
  1. 365
Platform
  1. Windows
Supongo que la hoj1 es la que tiene el código con el evento Change.
Prueba así:

VBA Code:
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 ,
VBA Code:
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

Well-known Member
Joined
Dec 3, 2018
Messages
13,770
Office Version
  1. 2007
Platform
  1. Windows
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.
 

Forum statistics

Threads
1,144,098
Messages
5,722,454
Members
422,436
Latest member
deadlock123

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top