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
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

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas