Solicito macro para Dante amor
Hola Dante.
Por favor facilitarme la macro de la siguiente pregunta.
"una Macro que identifique si una Fecha Especifica y una Hora especifica ya esta agendada"
Mi Email: [email protected]
Estaré por agradecido
1 respuesta
Respuesta de Dante Amor
1
Aquí la macro
Sub GrabarCita()
'Mod. Por.Dante Amor
' GrabarCita Macro
Dim fec As Date
'
Application.ScreenUpdating = False
Set h1 = Sheets("Ingreso")
Set h2 = Sheets("Agenda")
'
u = h2.Range("A" & Rows.Count).End(xlUp).Row + 1
fec = h1.[E3]
ho1 = h1.[E4]
ho2 = h1.[E5]
grabar = False
'
Set r = h2.Columns("A")
Set b = r.Find(fec)
If b Is Nothing Then
grabar = True
Else
grabar = True
ncell = b.Address
Do
f = b.Row
w1 = h2.Cells(b.Row, "B")
w2 = h2.Cells(b.Row, "C")
If ho1 >= h2.Cells(b.Row, "B") And ho1 <= h2.Cells(b.Row, "C") Then
res = MsgBox("Ya existe un paciente en ese horario" & vbCr & vbCr & _
"Presiona ''SI'' para borrar y poner en su lugar la nueva cita" & vbCr & _
"Presiona ''No'' para escribir la nueva cita en una fila nueva" & vbCr & _
"Presiona ''Cancelar'' para cancelar la operación", _
vbYesNoCancel, "REGISTRAR CITA")
'
Select Case res
Case vbYes
grabar = True
u = b.Row
Case vbNo
grabar = True
Case vbCancel
grabar = False
End Select
Exit Do
End If
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> ncell
End If
'
If grabar Then
h1.Range("E3:E6").Copy
h2.Range("A" & u).PasteSpecial Paste:=xlPasteValues, Transpose:=True
u = h2.Range("A" & Rows.Count).End(xlUp).Row + 1
With h2.Sort
.SortFields.Clear
.SortFields.Add Key:=h2.Range("A2:A" & u), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange h2.Range("A1:D" & u)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
h1.Range("E3:E6").ClearContents
h1.Range("E3").Select
End If
MsgBox "fin"
End SubTienes que poner así en la hoja "ingreso"
Y también tienes que tener una hoja llamada "Agenda"
