Macro que controla cambios en varias celdas de un rango / Macro that handles changes in multiple cells in a range

juanam

New Member
Joined
Aug 1, 2021
Messages
11
Office Version
  1. 2021
Platform
  1. Windows
SPANISH:
Estimados, uso Google Traductor porque mi inglés es muy básico.
He creado una macro que detecta cambios de valores en un rango de celdas y le cambia el color de fondo a la celda cambiada y 6 celdas a su izquierda, de color verde si se ingresa una fecha de egreso y de color blanco si se borra una fecha existente.
En mi proyecto de una base de datos de empleados, si se pone una fecha de egreso en la columna G (rango G5:G495) o se elimina una existente, se producen los cambios.

La macro funciona bien pero tiene algunas limitaciones que deseo resolver:
1) Al ingresar la fecha de egreso hay que pulsar la tecla enter o la flecha del teclado abajo, porque si se lo hace de otra manera (ejemplo la tecla tabulador) el rango de celdas a pintar no se respeta ya que el código toma la celda activa para efectuar los cambios.
2) El código funciona si los cambios se hacen de a una celda a la vez, si selecciono un rango de celdas para cambiar sus valores simultaneamente da error ("No coinciden los tipos".

¿Es posible solucionar estás 2 limitaciones o al menos la 2da.?

CODIGO:
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
'Comenté las 2 líneas siguientes para que vean las LIMITACIONES
'Application.EnableEvents = False
'On Error GoTo Error


    Dim KeyCells As Range


' La variable KeyCells contiene el rango
    ' de las celdas que se controlará su cambio.
    ' para este caso he creado un nombre de rango para G5:G495
    'que corresponde a la columna de Fecha de Egreso
    Set KeyCells = Range("FechaEgreso")


If Not Application.Intersect(KeyCells, Range(Target.Address)) _
           Is Nothing Then
        'Si el cambio en una de las celdas contiene un valor
        'es distinto que vacio le pondrá color de relleno verde
        If Range(Target.Address).Value <> "" Then
         'pintará la celda cambiada y 6 celdas hacia su izquierda
         'a la celda cambiada le pongo -1 porque al ingresar un valor
         'y dar enter la celda activa es la de abajo de esa (LIMITACION)
         Range(ActiveCell.Offset(-1, 0), ActiveCell.Offset(-1, -6)).Select
            'elige un color verde para el rango a pintar
            With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .Color = 65280
             End With
        'luego de pintar posiciona el cursor
        'una celda + abajo que la cambiada
        ActiveCell.Offset(1, 6).Select
        End If
        'si el cambio en la celda fue borrar un valor
        If Range(Target.Address).Value = "" Then
        'remueve el color verde de todo el rango
         Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, -6)).Select
            'eligiendo un color de relleno blanco
            With Selection.Interior
            .ColorIndex = 0
              
            End With
        'luego de revertir el color de relleno a blanco
        'posiciona el cursor en la misma celda que se
        'borró el valor
        ActiveCell.Offset(0, 6).Select
        
        End If
End If
'Comenté las 2 líneas siguientes para que vean las LIMITACIONES
'Error:
'Application.EnableEvents = True


End Sub

CAPTURA DE PANTALLA CAMBIANDO VALOR A UNA CELDA: :)
base_empleados.png


ERROR SI INTENTO CAMBIAR VARIAS CELDAS A LA VEZ: :(
base_empleados_error.png


Adjunto archivo de Excel Microsoft 365: Descargar
Muchas gracias por la ayuda que me puedan brindar.

=====================================================
ENGLISH:
Dear, I use Google Translate because my English is very basic.
I have created a macro that detects changes in values in a range of cells and changes the background color of the changed cell and 6 cells to its left, green if an exit date is entered and white if one is deleted existing date.
In my project of an employee database, if a discharge date is put in column G (range G5: G495) or an existing one is deleted, the changes take place.

The macro works fine but it has some limitations that I want to solve:
1) When entering the exit date, you have to press the enter key or the down arrow of the keyboard, because if you do it in another way (example the tabulator key) the range of cells to be painted is not respected since the code takes the active cell to make changes.
2) The code works if the changes are made one cell at a time, if I select a range of cells to change their values simultaneously it gives an error ("The types do not match".

Is it possible to solve these 2 limitations or at least the 2nd one?

CODE:
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
'I commented the next 2 lines to see the LIMITATIONS
'Application.EnableEvents = False
'On Error GoTo Error


    Dim KeyCells As Range


' The KeyCells variable contains the range
    ' of the cells that will be controlled its change.
    ' for this case I have created a range name for G5:G495
    'which corresponds to the discharge Date column
    Set KeyCells = Range("FechaEgreso")


If Not Application.Intersect(KeyCells, Range(Target.Address)) _
           Is Nothing Then
        'If the change in one of the cells contains a value
        'it is different that empty will put green fill color
        If Range(Target.Address).Value <> "" Then
         'It will paint the changed cell and 6 cells to its left
         'I put -1 to the changed cell because when entering a value
         'and I press the enter key, the active cell is the one below that (LIMITATION)
         Range(ActiveCell.Offset(-1, 0), ActiveCell.Offset(-1, -6)).Select
            'choose a green color for the range to be painted
            With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .Color = 65280
             End With
        'after painting position the cursor
        'a cell + below that changed
        ActiveCell.Offset(1, 6).Select
        End If
        'if the change in the cell was delete a value
        If Range(Target.Address).Value = "" Then
        'removes the green color from the entire range
         Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, -6)).Select
            'choosing a white fill color
            With Selection.Interior
            .ColorIndex = 0
              
            End With
        'after reverting the fill color to white
        'positions the cursor in the same cell that the value was deleted
         ActiveCell.Offset(0, 6).Select
        
        End If
End If
'I commented the next 2 lines to see the LIMITATIONS
'Error:
'Application.EnableEvents = True


End Sub
 

Excel Facts

Back into an answer in Excel
Use Data, What-If Analysis, Goal Seek to find the correct input cell value to reach a desired result

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
66,089
Office Version
  1. 365
Platform
  1. Windows
Hola y bienvenido a MrExcel.
Qué tal si

Hi & welcome to MrExcel.
How about

VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
   Dim KeyCells As Range, Cl As Range
   
   Set KeyCells = Intersect(Range("FechaEgreso"), Target)
   If Not KeyCells Is Nothing Then
      For Each Cl In KeyCells
         If Cl.Value <> "" Then
            Cl.Offset(, -6).Resize(, 7).Interior.Color = 65280
         Else
            Cl.Offset(, -6).Resize(, 7).Interior.ColorIndex = 0
         End If
      Next Cl
   End If
End Sub
 
Solution

juanam

New Member
Joined
Aug 1, 2021
Messages
11
Office Version
  1. 2021
Platform
  1. Windows
Hola y bienvenido a MrExcel.
Qué tal si

Hi & welcome to MrExcel.
How about

VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
   Dim KeyCells As Range, Cl As Range
  
   Set KeyCells = Intersect(Range("FechaEgreso"), Target)
   If Not KeyCells Is Nothing Then
      For Each Cl In KeyCells
         If Cl.Value <> "" Then
            Cl.Offset(, -6).Resize(, 7).Interior.Color = 65280
         Else
            Cl.Offset(, -6).Resize(, 7).Interior.ColorIndex = 0
         End If
      Next Cl
   End If
End Sub
Hi Fluff,
You are a genious! (y)
Work perfectly!!
Thk
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
66,089
Office Version
  1. 365
Platform
  1. Windows
You're welcome & thanks for the feedback.
 

Forum statistics

Threads
1,148,426
Messages
5,746,611
Members
424,033
Latest member
al1en

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