Agregar 2 instrucciones a macro actual de registro

Me gustaría que me puedas ayudar agregando 2 instrucciones más a una macro actual que ya tengo.

La primera instrucción adicional que quiero que me ayudes a incluir en la actual macro es que si la celda C9 contiene palabras como: Consulta o Control o Revisión o Retoque o Inasistencia o Procedimiento entonces unicamente haga lo que actualmente hace la actual macro (así como esta)

Pero si NO contiene alguna de esas palabras entonces aparte de hacer lo que hace la actual macro, adicional a eso, haga ese mismo proceso de copiado pero en la hoja "PROCEDIMIENTOS" del actual libro.

No se si me hice entender bien osea es casi que registrar dos veces los mismos datos pero en hojas diferentes en donde en una de las hojas llamada "CARTERA" se copian todos, pero en la hoja llamada "PROCEDIMIENTOS" solo se copian los que cumplan la condición de NO CONTENER alguna de esas palabras.

La segunda instrucción que me gustaría que me ayudes es que antes de terminar la actual macro antes de hacer el proceso de borrado de las celdas en la hoja "VISITAS" me pregunte a través de un msgbox "Ud desea realizar un nuevo registro con los mismo datos actuales?" en caso de responder que SI entonces termina la macro y no borra los datos de las celdas de la hoja "VISITAS" en caso de contestar que NO entonces ahí si borra los datos y termine la macro.

La macro actual es la siguiente:

Sub REGISTROS()
'Act.Por.Dante Amor
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    ActiveSheet.DisplayPageBreaks = False
    Set h1 = Sheets("VISITAS")
    Set h2 = Sheets("CARTERA")
    Set h4 = Sheets("CLIENTES")
    '
    u = h2.Range("A" & Rows.Count).End(xlUp).Row + 1
    h1.Range("C5:C14").Copy: h2.Range("A" & u).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    h1.Range("F5:F14").Copy: h2.Range("K" & u).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    h1.Range("F2").Copy: h2.Range("U" & u).PasteSpecial Paste:=xlPasteValues, Transpose:=False
    h2.Range("V3:Y3").Copy h2.Range("V" & u)
    h2.Range("F" & u).TextToColumns Destination:=h2.Range("Z" & u), DataType:=xlFixedWidth, _
        FieldInfo:=Array(Array(0, 2), Array(1, 1), Array(4, 1)), TrailingMinusNumbers:=True
    h2.Range("AC3").Copy h2.Range("AC" & u)
    h2.Range("H" & u).TextToColumns Destination:=h2.Range("AD" & u), _
        DataType:=xlDelimited, TextQualifier:=xlNone, ConsecutiveDelimiter:=True, Space:=True, _
        FieldInfo:=Array(Array(1, 2), Array(2, 2)), TrailingMinusNumbers:=True
    h2.Range("AF" & u) = "=TEXT(RC[-31],""yyyy"")"
    h2.Range("AG" & u) = "=TEXT(RC[-32],""mmmm"")"
    h2.Range("AH" & u) = "=IF(RC[-4]="""","""",IF(RC[-4]=""plan"",""Particulares"",RC[-3]))"
    Set b = h4.Columns("C").Find(h1.[C7], lookat:=xlWhole)
    If Not b Is Nothing Then
    h2.Range("AW" & u) = h4.Cells(b.Row, "F")
    End If
    '
    h1.Unprotect Password:="0976342842"
    H1. Range("F5:F7"). ClearContents
    H1. Range("F10:F12"). ClearContents
    H1. Range("F14"). ClearContents
    H1. Range("C6:C7"). ClearContents
    H1. Range("C9:C12"). ClearContents
    H1. Range("C14"). ClearContents
    h1.Range("F2") = h1.Range("F2") + 1
    h1.Protect Password:="0976342842"
    Application.ScreenUpdating = True
    ActiveWorkbook.Save
'INSTRUCCION DE GRABAR ARCHIVO REGISTRO EN COMPUTADOR DE NATHALIA AQUI
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
Application.CutCopyMode = False
Sheets("VISITAS").Select
End Sub

1 Respuesta

Respuesta
1

Prueba así:

mensaje = MsgBox("Ud desea realizar un nuevo registro con los mismo datos actuales?", vbYesNo + vbExclamation, strTitulo)
If mensaje = vbNo Then
Exit Sub
else
h1.Unprotect Password:="0976342842"
H1. Range("F5:F7"). ClearContents
H1. Range("F10:F12"). ClearContents
H1. Range("F14"). ClearContents
H1. Range("C6:C7"). ClearContents
H1. Range("C9:C12"). ClearContents
H1. Range("C14"). ClearContents
h1.Range("F2") = h1.Range("F2") + 1
h1.Protect Password:="0976342842"
End If

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas