Macro de eventos que revise si el dato evaluable se ha modificado
Para Dante Amor
Tengo un libro de Excel con una macro en la que me ayudaste por completo y funciona a la perfección. Realiza un evento para copiar registros a otras hojas según unas condiciones. Este evento se ejecuta una vez.
Podría necesitar enviar nuevas actualizaciones de los registros, aunque no sería tan imprescindible o necesario. Me explico. Podría seguir apuntando los registros en la pestaña “General” como hasta ahora. Éstos se copian a la hoja destino que toque, y después ya los voy modificando en las respectivas pestañas. Creo que así no sería estrictamente necesario modificar la macro.
En cualquier caso, imagina que he escrito datos de una venta en un registro, se activa el evento y se copia a la hoja de destino. Si por lo que sea me he equivocado al introducirlos, los borro y vuelvo a introducir otros nuevos, éstos ya no se copiaran porque al activarse el evento previo, se puso en 1 “EY”. ¿Existe alguna manera de que evalúe si el registro está vacío y vuelva a poner a 0 “EY”, es decir, si éste ha sufrido una modificación?
No sé si me he explicado bien.
Muchas gracias de nuevo, Dante!
Private Sub Worksheet_Change(ByVal Target As Range)
'Por.Dante Amor
Set h1 = ActiveSheet
Set h2 = Sheets("TTE+MTJ")
Set h3 = Sheets("TTE")
Set h4 = Sheets("Sin Servicios")
'
If Not Intersect(Target, Columns("CW")) Is Nothing Then
fila = Target.Row
If Target.Count > 1 Then Exit Sub
If fila < 16 Then Exit Sub
If Cells(fila, "H") = "" Then Exit Sub
If Cells(fila, "H") = "TOTALES" Then Exit Sub
If Target.Value = "" Then Exit Sub
If h1.Cells(fila, "EY") = 1 Then Exit Sub
'
'copia a TTE
If Cells(fila, "AI") <> "" And Cells(fila, "BF") = "" Then
u = 16
Do While h3.Cells(u, "H") <> ""
u = u + 1
Loop
h1.Range("A" & Target.Row & ":DT" & fila).Copy h3.Range("A" & u)
h1.Cells(fila, "EY") = 1
End If
'copia a TTE+MTJ
If Cells(fila, "AI") <> "" And Cells(fila, "BF") <> "" Then
u = 16
Do While h2.Cells(u, "H") <> ""
u = u + 1
Loop
h1.Range("A" & Target.Row & ":EX" & fila).Copy h2.Range("A" & u)
h1.Cells(fila, "EY") = 1
End If
'copia a SinServicios
If Cells(fila, "AI") = "" And Cells(fila, "BF") = "" Then
u = 16
Do While h4.Cells(u, "H") <> ""
u = u + 1
Loop
h1.Range("A" & Target.Row & ":DT" & fila).Copy h4.Range("A" & u)
h1.Cells(fila, "EY") = 1
End If
End If
End Sub
1 Respuesta
Te anexo la macro actualizada
Private Sub Worksheet_Change(ByVal Target As Range)
'Por.Dante Amor
Set h1 = ActiveSheet
Set h2 = Sheets("TTE+MTJ")
Set h3 = Sheets("TTE")
Set h4 = Sheets("Sin Servicios")
'
If Not Intersect(Target, Columns("K:DT")) Is Nothing Then
'
fila = Target.Row
If Target.Count > 1 Then Exit Sub
If fila < 16 Then Exit Sub
If Cells(fila, "H") = "" Then Exit Sub
If Cells(fila, "H") = "TOTALES" Then Exit Sub
If Target.Column = Columns("AI").Column Or _
Target.Column = Columns("BF").Column Then Exit Sub
'If Target.Value = "" Then Exit Sub
Application.ScreenUpdating = False
h1.Unprotect "qwer"
H2. Unprotect "qwer"
H3. Unprotect "qwer"
H4. Unprotect "qwer"
If h1.Cells(fila, "EY") = 1 Then 'Exit Sub
'modificaciones
'
cliente = h1.Cells(Target.Row, "H")
Set b = h2.Range("H15:J" & Rows.Count).Find(cliente, lookat:=xlWhole)
If Not b Is Nothing Then
h1.Range("K" & fila & ":DT" & fila).Copy h2.Range("K" & b.Row)
Else
Set b = h3.Range("H15:J" & Rows.Count).Find(cliente, lookat:=xlWhole)
If Not b Is Nothing Then
h1.Range("K" & fila & ":DT" & fila).Copy h3.Range("K" & b.Row)
Else
Set b = h4.Range("H15:J" & Rows.Count).Find(cliente, lookat:=xlWhole)
If Not b Is Nothing Then
h1.Range("K" & fila & ":DT" & fila).Copy h4.Range("K" & b.Row)
End If
End If
End If
Else
'altas
'copia a TTE
If Cells(fila, "AI") <> "" And Cells(fila, "BF") = "" Then
u = 16
Do While h3.Cells(u, "H") <> ""
u = u + 1
Loop
h1.Range("A" & fila & ":DT" & fila).Copy h3.Range("A" & u)
h1.Cells(fila, "EY") = 1
End If
'copia a TTE+MTJ
If Cells(fila, "AI") <> "" And Cells(fila, "BF") <> "" Then
u = 16
Do While h2.Cells(u, "H") <> ""
u = u + 1
Loop
h1.Range("A" & fila & ":EX" & fila).Copy h2.Range("A" & u)
h1.Cells(fila, "EY") = 1
End If
'copia a SinServicios
If Cells(fila, "AI") = "" And Cells(fila, "BF") = "" Then
u = 16
Do While h4.Cells(u, "H") <> ""
u = u + 1
Loop
h1.Range("A" & fila & ":DT" & fila).Copy h4.Range("A" & u)
h1.Cells(fila, "EY") = 1
End If
End If
h1.Protect "qwer", DrawingObjects:=True, Contents:=True, _
Scenarios:=True, AllowFormattingCells:=True
h2.Protect "qwer", DrawingObjects:=True, Contents:=True, _
Scenarios:=True, AllowFormattingCells:=True
h3.Protect "qwer", DrawingObjects:=True, Contents:=True, _
Scenarios:=True, AllowFormattingCells:=True
h4.Protect "qwer", DrawingObjects:=True, Contents:=True, _
Scenarios:=True, AllowFormattingCells:=True
Application.ScreenUpdating = True
End If
End Sub.
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
.
Avísame cualquier duda
.
