Actualizar Horarios a formulario de Registro de Citas
Pregunta # 4 pendiente de realizar.
Actualizar horarios en formato de 24 horas a 12 horas en formulario de Registro de Citas.
En espera de respuesta para su calificación.
1 respuesta
Respuesta de Dante Amor
1
H o l a:
Te anexo la macro para actualizar horarios
'
Sub ActualizarHorarios()
'Por.Dante Amor
'Actualizar horarios
Set h1 = Sheets("INGRESAR_CITA")
Set h2 = Sheets("Agenda")
Set h3 = Sheets("Horarios")
'
If Label2 = "" Then Exit Sub
u = h2.Range("B" & Rows.Count).End(xlUp).Row
With h2.Sort
.SortFields.Clear: .SortFields.Add Key:=h2.Range("B2:B" & u)
.SortFields.Add Key:=h2.Range("C2:C" & u)
.SetRange h2.Range("B1:D" & u): .Header = xlYes: .Apply
End With
'
For j = 1 To h3.Range("K" & Rows.Count).End(xlUp).Row
etiq = "h" & Format(Hour(h3.Cells(j, "J")), "00") & Format(Minute(h3.Cells(j, "J")), "00")
Me.Controls(etiq).BackColor = &HC0FFC0 'Verde
Me.Controls(etiq).Enabled = True
Me.Controls(etiq).Visible = True
'
dia = Format(h1.[D22], "dddd")
If dia = "Sábado" Then
If j >= 28 Then
Me.Controls(etiq).BackColor = &HFF& 'Rojo
Me.Controls(etiq).Enabled = False
Me.Controls(etiq).Visible = False
End If
Else
If j >= 25 And j <= 27 Then
Me.Controls(etiq).BackColor = &HFF& 'Rojo
Me.Controls(etiq).Enabled = False
Me.Controls(etiq).Visible = False
End If
End If
'
Set r = h2.Columns("B")
Set b = r.Find(h1.[D22], LookAt:=xlWhole)
If Not b Is Nothing Then
ncell = b.Address
Do
'detalle
If h3.Cells(j, "K") >= h2.Cells(b.Row, "C") And h3.Cells(j, "K") < h2.Cells(b.Row, "D") Then
Me.Controls(etiq).BackColor = &HFF& 'Rojo"
Me.Controls(etiq).Enabled = False
End If
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> ncell
End If
Next
End Sub'
S a l u d o s
