Agregar instrucciones a Macro ya existente

Me pueden ayudar con las nuevas instrucciones que necesito según esta macro:

Sub GrabarPacienteRevision()
'Aqui necesito una instrucción que revise si el contenido de la celda "D9"
'se encuentra en la columna "F" de la hoja "Revision"
'si lo encuentra entonces:
msgbox "Dicho paciente tiene en espera una REVISIÓN" + chr(13) + "Desea eliminarlo de REVISIONES PENDIENTES?" + chr(13) + chr(13) + "Oprima SI para elimina esa REVISION" + chr(13) + "Oprima NO para mantener esa REVISION", vbYesNo, "PACIENTES POR REVISION !!!" 
'Aqui necesito las instrucciones para realizar lo siguiente:
'Si oprime SI una instrucción que elimine la fila correspondiente de la hoja "Revision" donde se encontró el respectivo dato y luego exit sub.
'Si oprime NO entonces exit sub.
'Si el dato de la celda "D9" no es encontrado en la columna "F" de la hoja "Revision" entonces ejecute las siguientes acciones:
Sheets("Revision").Unprotect Password:="0976342842"
Sheets("INGRESAR_CITA").Unprotect Password:="0976342842"
    Application.ScreenUpdating = False
    Set h1 = Sheets("INGRESAR_CITA")
    Set h2 = Sheets("Revision")
    u = h2.Range("A" & Rows.Count).End(xlUp).Row + 1
        h1.Range("D100:D116").Copy
        h2.Range("A" & u).PasteSpecial Paste:=xlPasteValues, Transpose:=True
        With h2.Sort
            .SortFields.Clear
            .SortFields.Add Key:=h2.Range("B2:B" & u), _
                SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SetRange h2.Range("A1:N" & u)
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        h1.Range("D8:D24").ClearContents
        h1.Range("D6:D6").ClearContents
        h1.Range("D6").Select
        Sheets("Revision").Protect Password:="0976342842"
        MsgBox "Se registró el Paciente para Revisión EXITOSAMENTE ....", vbExclamation, "PACIENTES REVISIÓN!!!"
        Sheets("INGRESAR_CITA").Protect Password:="0976342842"
    Application.ScreenUpdating = True
    Application.Visible = True
ActiveWorkbook.Save
End Sub

1 Respuesta

Respuesta
1

H o l a:

Te anexo la macro actualizada:

Sub GrabarPacienteRevision()
'Act.Por.Dante Amor
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set h1 = Sheets("INGRESAR_CITA")
    Set h2 = Sheets("Revision")
    h1.Unprotect Password:="0976342842"
    h2.Unprotect Password:="0976342842"
    '
    'Aqui necesito una instrucción que revise si el contenido de la celda "D9"
    'se encuentra en la columna "F" de la hoja "Revision"
    Set b = h2.Columns("F").Find(h1.[D9], lookat:=xlWhole)
    If Not b Is Nothing Then
        '
        'si lo encuentra entonces:
        res = MsgBox("Dicho paciente tiene en espera una REVISIÓN" & Chr(13) & _
                     "Desea eliminarlo de REVISIONES PENDIENTES?" & Chr(13) & Chr(13) & _
                     "Oprima SI para elimina esa REVISION" & Chr(13) & _
                     "Oprima NO para mantener esa REVISION", vbYesNo, "PACIENTES POR REVISION !!!")
        'Aqui necesito las instrucciones para realizar lo siguiente:
        If res = vbYes Then
            'Si oprime SI una instrucción que elimine la fila correspondiente de la hoja
            '"Revision" donde se encontró el respectivo dato y luego exit sub.
            h2.Rows(b.Row).Delete
        End If
        'Si oprime NO entonces exit sub.
        Exit Sub
    Else
        '
        'Si el dato de la celda "D9" no es encontrado en la columna "F"
        'de la hoja "Revision" entonces ejecute las siguientes acciones:
        u = h2.Range("A" & Rows.Count).End(xlUp).Row + 1
        h1.Range("D100:D116").Copy
        h2.Range("A" & u).PasteSpecial Paste:=xlPasteValues, Transpose:=True
        With h2.Sort
            .SortFields.Clear
            .SortFields.Add Key:=h2.Range("B2:B" & u), _
                SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SetRange h2.Range("A1:N" & u)
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        h1.Range("D8:D24").ClearContents
        h1.Range("D6:D6").ClearContents
        h1.Range("D6").Select
    End If
    h1.Protect Password:="0976342842"
    h2.Protect Password:="0976342842"
    Application.ScreenUpdating = True
    Application.Visible = True
    ActiveWorkbook.Save
    MsgBox "Se registró el Paciente para Revisión EXITOSAMENTE ....", vbExclamation, "PACIENTES REVISIÓN!!!"
End Sub

s a l u d o s

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas