Cambiar un estado a "incompleto" n veces y que el registro solo me copie una vez a otro libro de excel
Me funcionó a la perfección la macro anterior, pero cuando cambio el estado a INCOMPLETO más de una vez a un solo registro, este se copia nuevamente en el otro libro y quisiera que solo se copie una vez sin importar la cantidad de veces que yo escriba en el estado INCOMPLETO en ese registro.
1 Respuesta
Respuesta de Dante Amor
2
H o l a:
Te anexo la macro actualizada
Private Sub Worksheet_Change(ByVal Target As Range)
'Por.Dante Amor
Application.ScreenUpdating = False
Set l1 = ThisWorkbook
Set h1 = Sheets("WA CONSOLIDADO 2015-5")
Set l2 = Workbooks("BASE DE BLOQUEO WA 2016-3.xlsx")
hojas = Array("1 CICLO", "2 CICLO", "3 CICLO")
col = "A"
existe = False
n = 0
'
If Not Intersect(Target, Columns("W")) Is Nothing Then
For Each c In Target
codigo = Cells(c.Row, col)
Select Case UCase(c.Value)
Case "COMPLETO"
For h = LBound(hojas) To UBound(hojas)
Set h2 = l2.Sheets(hojas(h))
Set b = h2.Columns(col).Find(codigo, lookat:=xlWhole)
If Not b Is Nothing Then
h2.Rows(b.Row).Delete
existe = True
n = n + 1
End If
Next
Case "INCOMPLETO"
Select Case Cells(c.Row, "I")
Case 1: Set h2 = l2.Sheets("1 CICLO")
Case 2: Set h2 = l2.Sheets("2 CICLO")
Case 3: Set h2 = l2.Sheets("3 CICLO")
End Select
Set b = h2.Columns(col).Find(codigo, lookat:=xlWhole)
If Not b Is Nothing Then
h1.Rows(c.Row).Copy
h2.Rows(b.Row).PasteSpecial xlValues
Else
u = h2.Range("W" & Rows.Count).End(xlUp).Row + 1
h1.Rows(c.Row).Copy
h2.Rows(u).PasteSpecial xlValues
End If
existe = True
n = n + 1
End Select
Next
Application.CutCopyMode = False
Application.ScreenUpdating = False
If existe Then
l2.Save
MsgBox "Registros actualizados: " & n
End If
End If
End Sub‘
S a l u d o s . D a n t e A m o r. Recuerda valorar la respuesta. G r a c i a s
Gracias, pero cada vez que coloco estado INCOMPLETO a un mismo registro siempre me guarda en el otro libro de Excel, la idea era que me copie solo una vez. Espero me puedas ayudar, gracias
Quita esta línea de la macro
L2. Save
Así quedaría mejor:
Private Sub Worksheet_Change(ByVal Target As Range)
'Por.Dante Amor
Application.ScreenUpdating = False
Set l1 = ThisWorkbook
Set h1 = Sheets("WA CONSOLIDADO 2015-5")
Set l2 = Workbooks("BASE DE BLOQUEO WA 2016-3.xlsx")
hojas = Array("1 CICLO", "2 CICLO", "3 CICLO")
col = "A"
existe = False
n = 0
'
If Not Intersect(Target, Columns("W")) Is Nothing Then
For Each c In Target
codigo = Cells(c.Row, col)
Select Case UCase(c.Value)
Case "COMPLETO"
For h = LBound(hojas) To UBound(hojas)
Set h2 = l2.Sheets(hojas(h))
Set b = h2.Columns(col).Find(codigo, lookat:=xlWhole)
If Not b Is Nothing Then
h2.Rows(b.Row).Delete
existe = True
n = n + 1
End If
Next
Case "INCOMPLETO"
Select Case Cells(c.Row, "I")
Case 1: Set h2 = l2.Sheets("1 CICLO")
Case 2: Set h2 = l2.Sheets("2 CICLO")
Case 3: Set h2 = l2.Sheets("3 CICLO")
End Select
Set b = h2.Columns(col).Find(codigo, lookat:=xlWhole)
If Not b Is Nothing Then
If UCase(h2.Cells(b.Row, "W")) <> "INCOMPLETO" Then
h1.Rows(c.Row).Copy
h2.Rows(b.Row).PasteSpecial xlValues
existe = True
End If
Else
u = h2.Range("W" & Rows.Count).End(xlUp).Row + 1
h1.Rows(c.Row).Copy
h2.Rows(u).PasteSpecial xlValues
existe = True
End If
n = n + 1
End Select
Next
Application.CutCopyMode = False
Application.ScreenUpdating = False
If existe Then
l2.Save
MsgBox "Registros actualizados: " & n
End If
End If
End Sub‘
S a l u d o s . D a n t e A m o r. Recuerda valorar la respuesta. G r a c i a s
