Agregar una nueva instrucción a una macro ya existente
Tengo la siguiente macro que funciona muy bien:
Sub Buscar2()
'Por.Dante Amor
Set h2 = Sheets("BASE")
Set h3 = Sheets("INGRESAR_CITA")
h3.[D8:D24].ClearContents
'
If h3.[D6] = "" Then
MsgBox "Número de Identificación VACIO." & vbCrLf & "" & vbCrLf & "Por favor escriba el número de Identificación en el espacio correspondiente.", vbExclamation
[D6].Select
Exit Sub
End If
'
Set b = h2.Columns("C").Find(h3.[D6], lookat:=xlWhole)
If Not b Is Nothing Then
h3.[D8] = h2.Cells(b.Row, "B")
h3.[D9] = h2.Cells(b.Row, "C")
h3.[D10] = h2.Cells(b.Row, "D")
h3.[D11] = h2.Cells(b.Row, "E")
h3.[D12] = h2.Cells(b.Row, "F")
h3.[D13] = h2.Cells(b.Row, "G")
h3.[D14] = h2.Cells(b.Row, "H")
h3.[D15] = h2.Cells(b.Row, "I")
h3.[D16] = h2.Cells(b.Row, "J")
h3.[D17] = h2.Cells(b.Row, "K")
h3.[D18] = h2.Cells(b.Row, "L")
h3.[D19] = h2.Cells(b.Row, "M")
'NUEVA INSTRUCCION AQUI
DeleteFiltroAvanzado
BuscaUltimasCitas
Else
MsgBox "El número de Identificación no existe en la BASE DE DATOS." & vbCrLf & "" & vbCrLf & "Si es PACIENTE NUEVO por favor continúe en las siguientes celdas registrando sus datos." & vbCrLf & "" & vbCrLf & "Si es PACIENTE ANTIGUO por favor verifique con el PACIENTE el número de Identificación e Intentelo de nuevo.", vbExclamation
Temp1
anoymeses
Range("D8").Select
End If
End SubTengo una hoja llamada "AGENDA" y en dicha hoja tengo citas programadas de cada cliente. Desearia que esta macro en el espacio que puse como "NUEVA INSTRUCCION AQUI" busque si h3.[D6] se encuentra registrado en la columna "F" de la hoja "AGENDA" y si la fecha de la cita que es la registrada en la columna "B" de la hoja "AGENDA" es superior a la fecha actual, entonces salga un msgbox diciendo "Este paciente ya posee una cita para el dia "Columna B", desea eliminar esta cita y continuar el registro de la nueva cita?"
Si la respuesta es "Si" entonces quisiera que tome el dato contenido en la columna "R" y lo copie en la celda "D4" de la hoja "REAGENDAR" y ejecute la macro "EliminarCita". Y luego vuelva a la hoja "Ingresar_Cita" y continue con las instrucciones que siguen.
Si la respuesta es "No" entonces continua con las instrucciones que siguen.
1 Respuesta
H o l a:
Te anexo la macro actualizada.
Sub Buscar2()
'Por.Dante Amor
Set h2 = Sheets("BASE")
Set h3 = Sheets("INGRESAR_CITA")
Set h4 = Sheets("AGENDA")
Set h5 = Sheets("REAGENDAR")
h3.[D8:D24].ClearContents
'
If h3.[D6] = "" Then
MsgBox "Número de Identificación VACIO." & vbCrLf & "" & vbCrLf & "Por favor escriba el número de Identificación en el espacio correspondiente.", vbExclamation
[D6].Select
Exit Sub
End If
'
Set b = h2.Columns("C").Find(h3.[D6], lookat:=xlWhole)
If Not b Is Nothing Then
h3.[D8] = h2.Cells(b.Row, "B")
h3.[D9] = h2.Cells(b.Row, "C")
h3.[D10] = h2.Cells(b.Row, "D")
h3.[D11] = h2.Cells(b.Row, "E")
h3.[D12] = h2.Cells(b.Row, "F")
h3.[D13] = h2.Cells(b.Row, "G")
h3.[D14] = h2.Cells(b.Row, "H")
h3.[D15] = h2.Cells(b.Row, "I")
h3.[D16] = h2.Cells(b.Row, "J")
h3.[D17] = h2.Cells(b.Row, "K")
h3.[D18] = h2.Cells(b.Row, "L")
h3.[D19] = h2.Cells(b.Row, "M")
'NUEVA INSTRUCCION AQUI
'
Set b = h4.Columns("F").Find(h3.[D6], lookat:=xlWhole)
If Not b Is Nothing Then
If h4.Cells(b.Row, "B") > Date Then
res = MsgBox("Este paciente ya posee una cita para el dia: " & _
h4.Cells(b.Row, "B") & ", desea eliminar esta cita " & _
"y continuar el registro de la nueva cita?", vbQuestion & vbYesNo)
If res = vbYes Then
h5.[D4] = h4.Cells(b.Row, "R")
EliminarCita
End If
End If
End If
'
DeleteFiltroAvanzado
BuscaUltimasCitas
Else
MsgBox "El número de Identificación no existe en la BASE DE DATOS." & vbCrLf & "" & vbCrLf & "Si es PACIENTE NUEVO por favor continúe en las siguientes celdas registrando sus datos." & vbCrLf & "" & vbCrLf & "Si es PACIENTE ANTIGUO por favor verifique con el PACIENTE el número de Identificación e Intentelo de nuevo.", vbExclamation
Temp1
anoymeses
Range("D8").Select
End If
End Subs a l u d o s
