Modificar tu macro para sacar señales

tengo libro con hojas....clientes señales gestión y archivo....ya conseguido el archivar los datos ahora necesito que se borren las señales....te cuento

a.............b.............c.................d..........e

nºcliente.........nombre......fecha......cantidad.......tipo

el nº cliente es igual en todas las hojas....y quiero borrarlas al ejecutar la macro teniendo en cuenta que puede haber varias repetidas osea que tenga varias entregas a cuenta.....

osea cuando se borra la fila de gestión que busgue en señales y borre también si aparece nº cliente...

te pongo tu macro para recordar...

Sub SACASERVIDO()
'***Macro***
'Borra de gestión si situación = servido
'Borra de clientes si no tiene nada en gestión y lo pasa a archivo
'Por.daM
Worksheets("CLIENTES").Select
ALTURA_CLIENTES = Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select
ufil_clientes = ALTURA_CLIENTES
ucol_clientes = 20
Worksheets("GESTIÓN").Select
ALTURA_GESTION = Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select
ufil_gestion = ALTURA_GESTION
ucol_gestion = 30
Worksheets("ARCHIVO").Select
ALTURA_ARCHIVO = Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select
ufil_archivo = ALTURA_ARCHIVO
ucol_archivo = 50
'inicia la con gestión
Worksheets("GESTIÓN").Select
For i = 3 To ufil_gestion
If Cells(i, 7) = "SERVIDO" Then
'Si ya fue servido lo pasa a archivo y lo borra
num_cliente = Cells(i, 1)
Range(Cells(i, 10), Cells(i, 16)).Select
Range(Cells(i, 10), Cells(i, 16)).Copy
Worksheets("ARCHIVO").Select
ufil_archivo = ufil_archivo + 1
Cells(ufil_archivo, 12).Select
ActiveSheet.Paste
Worksheets("CLIENTES").Select
Range("A:A").Select
Set RangoObj = Selection.Find(What:=num_cliente, _
After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If RangoObj Is Nothing Then
MsgBox ("cliente no encontrado")
Else
k = RangoObj.Row
Range(Cells(k, 1), Cells(k, 11)).Select
Selection.Copy
Worksheets("ARCHIVO").Select
Cells(ufil_archivo, 1).Select
ActiveSheet.Paste
'Sheets("DATOS").Select
End If
Worksheets("GESTIÓN").Select
ActiveCell.EntireRow.Delete
End If
Next 'fin gestión
'inicia clientes
Worksheets("CLIENTES").Select
For i = 3 To ufil_clientes
Cells(i, 1).Select
num_cliente = Cells(i, 1)
Worksheets("GESTIÓN").Select
Range("A:A").Select
Set RangoObj = Selection.Find(What:=num_cliente, _
After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
Worksheets("CLIENTES").Select
If RangoObj Is Nothing Then
ActiveCell.EntireRow.Delete
End If
Next
Worksheets("ARCHIVO").Select
End Sub

como ves la he modificado algo....

muchas gracias por todo

juanjo

1 Respuesta

Respuesta
1

Te mando la nueva macro

Sub clientes()
'Borra de gestion si situacion = servido
'Borra de clientes si no tiene nada en gestión y lo pasa a archivo
'Por.daM
Worksheets("CLIENTES").Select
    ufil_clientes = ActiveCell.SpecialCells(xlLastCell).Row
    ucol_clientes = ActiveCell.SpecialCells(xlLastCell).Column
Worksheets("GESTION").Select
    ufil_gestion = ActiveCell.SpecialCells(xlLastCell).Row
    ucol_gestion = ActiveCell.SpecialCells(xlLastCell).Column
Worksheets("ARCHIVO").Select
    ufil_archivo = ActiveCell.SpecialCells(xlLastCell).Row
    ucol_archivo = ActiveCell.SpecialCells(xlLastCell).Column
'inicia borrado en gestion
Worksheets("GESTION").Select
For i = 4 To ufil_gestion
    If Cells(i, 7) = "SERVIDO" Then
        'Si ya fue servido lo pasa a archivo y lo borra
        num_cliente = Cells(i, 1)
        Range(Cells(i, 3), Cells(i, 7)).Select
        Range(Cells(i, 3), Cells(i, 7)).Copy
        Worksheets("ARCHIVO").Select
        ufil_archivo = ufil_archivo + 1
        Cells(ufil_archivo, 8).Select
        ActiveSheet.Paste
        Worksheets("CLIENTES").Select
        Range("A:A").Select
        Set RangoObj = Selection.Find(What:=num_cliente, _
            After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
            xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
        If RangoObj Is Nothing Then
            MsgBox ("cliente no encontrado")
        Else
            k = RangoObj.Row
            Range(Cells(k, 1), Cells(k, 7)).Select
            Selection.Copy
            Worksheets("ARCHIVO").Select
            Cells(ufil_archivo, 1).Select
            ActiveSheet.Paste
            'Sheets("DATOS").Select
        End If
        Worksheets("GESTION").Select
        ActiveCell.EntireRow.Delete
        ufil_gestion = ActiveCell.SpecialCells(xlLastCell).Row
        'Borra de SEÑALES
        Worksheets("SEÑALES").Select
        Range("A:A").Select
        Set RangoObj = Selection.Find(What:=num_cliente, _
            After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
            xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
        If Not RangoObj Is Nothing Then
            Cells(RangoObj.Row, 1).Select
            ActiveCell.EntireRow.Delete
        End If
        Do While Not RangoObj Is Nothing
            Set RangoObj = Selection.FindNext(After:=ActiveCell)
            If Not RangoObj Is Nothing Then
                Cells(RangoObj.Row, 1).Select
                ActiveCell.EntireRow.Delete
            End If
        Loop
        Worksheets("GESTION").Select
    End If
Next 'fin gestion
'inicia clientes
Worksheets("CLIENTES").Select
For i = 4 To ufil_clientes
    Cells(i, 1).Select
    num_cliente = Cells(i, 1)
    Worksheets("GESTION").Select
    Range("A:A").Select
    Set RangoObj = Selection.Find(What:=num_cliente, _
        After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
        Worksheets("CLIENTES").Select
        If RangoObj Is Nothing Then
            ActiveCell.EntireRow.Delete
        End If
Next
End Sub
'***Macro***

saludos.dam

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas