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.

Respuesta
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

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas