Une date x saisie dans un inputbox connaitre l'heure de mise

Le 11/12/2012 à 15:36

BOnjour a tous

Je desire, à une date x saisie dans un inputbox connaitre

  • l'heure de mise en MARCHE
  • l'heure d'arrêt
  • heure du premier ---- ON ----
  • heure du dernier ---- ON ----

EX : si je saisie 11/12/2012 dans un inputbox, dans un msgbox, j'ai :

  • heure de mise en marche 13:24:33
  • heure d'arrêt 14:35:39
  • debut ---- ON ---- 13:24:36
  • fin ---- ON ---- 14:35:37

si je saisie 12/11/2012

jai : heure de mise en marche (hh mn s)

heure d'arrêt (hh mn s)

debut ---- ON ---- (hh mn s)

fin ---- ON ----(hh mn s)

Voici le code mais ça ne marche pas

Private Sub heuredebutheurefin_Click()
Dim m As Integer, Date_Réf As Date, Ligne_fin As Integer, Date_Réf_Col As Integer, Date_Réf_Lig As Integer
Dim Réf_Marche As String, Réf_Arrêt As String, Réf_Ok_Début As String, Réf_Ok_Fin As String

Application.ScreenUpdating = False

On Error GoTo Etiquette
Date_Réf = InputBox("Quelle est la date choisie ?")
Etiquette:
If Date_Réf = 0 Then
    MsgBox ("La saisie n'est pas une date")
    Exit Sub
End If

Worksheet.Activate

Do Until ActiveCell = Date_Réf
    ActiveCell.Offset(1, 0).Activate
    If ActiveCell.Row = Ligne_fin + 10 Then
        MsgBox ("Date introuvable")
        Exit Sub
    End If
Loop

Date_Réf_Col = ActiveCell.Column
Date_Réf_Lig = ActiveCell.Row

On Error Resume Next

Do
m = 0
m = WorksheetFunction.Search("  ---- MARCHE ----", ActiveCell.Offset(1, 0))
If m > 0 Then Réf_Marche = Left(ActiveCell.Offset(1, 0), 8)
ActiveCell.Offset(1, 0).Activate
Loop Until m > 0

Cells(Date_Réf_Lig, Date_Réf_Col).Activate
Do
m = 0
m = WorksheetFunction.Search(" ---- ARRET ----", ActiveCell.Offset(1, 0))
If m > 0 Then Réf_Arrêt = Left(ActiveCell.Offset(1, 0), 8)
ActiveCell.Offset(1, 0).Activate
Loop Until m > 0

Cells(Date_Réf_Lig, Date_Réf_Col).Activate
Do
m = 0
m = WorksheetFunction.Search("---- ON ----", ActiveCell.Offset(1, 0))
If m > 0 Then Réf_Ok_Début = Left(ActiveCell.Offset(1, 0), 8)
ActiveCell.Offset(1, 0).Activate
Loop Until m > 0

'On part à l'envers pour la dernière référence
Worksheet.Activate

Do Until ActiveCell = Date_Réf
    ActiveCell.Offset(-1, 0).Activate
Loop

Do
m = 0
m = WorksheetFunction.Search("---- ON ----", ActiveCell.Offset(1, 0))
If m > 0 Then Réf_Ok_Fin = Left(ActiveCell.Offset(1, 0), 8)
ActiveCell.Offset(-1, 0).Activate
Loop Until m > 0

MsgBox (Date_Réf & vbNewLine & vbNewLine & "Mise en marche : " & vbNewLine & Réf_Marche & vbNewLine & vbNewLine & "Arrêt : " & vbNewLine & Réf_Arrêt & vbNewLine & vbNewLine & "Début ON: " & vbNewLine & Réf_Ok_Début & vbNewLine & vbNewLine & " Fin ON: " & vbNewLine & Réf_Ok_Fin)

End Sub

Cordialement

40exemple.xlsm (23.25 Ko)
Le 11/12/2012 à 18:21

Bonsoir,

Pas très claires tes explication !

Ta recherche doit se faire sur toutes les pages en même temps ou sur une seule page ? Dans ton exemple, tu donne :

EX : si je saisie 11/12/2012 dans un inputbox, dans un msgbox, j'ai :

  • heure de mise en marche 13:24:33
  • heure d'arrêt 14:35:39
  • debut ---- ON ---- 13:24:36
  • fin ---- ON ---- 14:35:37

Dans ton classeur en feuille "fiche 1" colonne A il y a "11/12/2012 13:24:33 ---- MARCHE ----" et c'est en feuille "fiche 3" qu'il y a "11/12/2012 14:35:39 ---- ARRET ----"

Si les valeurs sont entées dans plusieurs feuilles et si en plus on risque de les trouver dans différentes colonnes pas sûr que les résultats soient ceux escomptés mais bon, j'ai fais un code à toi de tester.

Le code passe sur toutes les feuilles du classeur et la recherche porte sur toutes les cellules contenant des valeurs constantes.

Attention, tes dates ne sont en fait pas des dates comme tu semble le croire mais du texte (elles font partie d'une chaîne de texte dans les cellules). Une date est un nombre et les décimales de ce nombre sont les heures. Pour cette date "11/12/2012 13:45:46", sa valeur est 41254,5734490741. 41254 est la date soit le 11/12/2012 et 0,5734490741 sont les heures, soit 13:45:46.

Sub Trouver()

    Dim Fe As Worksheet
    Dim Plage As Range
    Dim Cel As Range
    Dim DateTest As Date
    Dim Date_Ref As String
    Dim Adr As String
    Dim Message As String

    'la date doit être sous forme de String car elles sont toutes dans une chaîne et non sous forme de date
    Date_Ref = InputBox("Quelle est la date choisie ?" & vbCrLf & vbCrLf & "Entrez la date sous le format 'jj/mm/aaaa'")

    'teste malgrè tout si c'est une date
    On Error Resume Next
    DateTest = CDate(Date_Ref)

    If Err.Number <> 0 Then

        MsgBox "Date invalide !"
        Exit Sub

    End If

    For Each Fe In Worksheets

        'défini la plage de recherche sur toutes les cellules utilisées sur la feuille "fiche 1"
        Set Plage = Fe.Cells.SpecialCells(2)

        'effectue une recherche partielle de la date
        Set Cel = Plage.Find(Date_Ref, , xlValues, xlPart)

        'si trouvée, boucle sur les cellules à la recherche du mot "MARCHE"
        If Not Cel Is Nothing Then

            Adr = Cel.Address

            Do

                If InStr(Cel.Value, "MARCHE") <> 0 Then

                    Message = "- heure de mise en marche " & Mid(Cel.Value, InStr(Cel.Value, " ") + 1, 8) & vbCrLf
                    Message = Message & "- debut ---- ON ---- " & Mid(Cel.Offset(1, 0).Value, InStr(Cel.Offset(1, 0).Value, " ") + 1, 8) & vbCrLf

                    Exit Do

                Else

                    Set Cel = Plage.FindNext(Cel)

                End If

            Loop While Adr <> Cel.Address

        End If

        'défini la plage de recherche sur toutes les cellules utilisées sur la feuille "fiche 3"
        Set Plage = Fe.Cells.SpecialCells(2)

        Set Cel = Plage.Find(Date_Ref, , xlValues, xlPart)

        'si trouvée, boucle sur les cellules à la recherche du mot "MARCHE"
        If Not Cel Is Nothing Then

            Adr = Cel.Address

            Do

                If InStr(Cel.Value, "ARRET") <> 0 Then

                    Message = Message & "- heure d'arrêt " & Mid(Cel.Value, InStr(Cel.Value, " ") + 1, 8) & vbCrLf
                    Message = Message & "- fin ---- ON ---- " & Mid(Cel.Offset(-1, 0).Value, InStr(Cel.Offset(-1, 0).Value, " ") + 1, 8)

                    Exit Do

                Else

                    Set Cel = Plage.FindNext(Cel)

                End If

            Loop While Adr <> Cel.Address

        End If

    Next Fe

    If InStr(Message, "marche") <> 0 _
    And InStr(Message, "d'arrêt") <> 0 And _
    InStr(Message, "debut") <> 0 _
    And InStr(Message, "fin") <> 0 Then

        MsgBox Message

    Else

        MsgBox "Données incomplètes !"

    End If

End Sub

Hervé.

Le 12/12/2012 à 11:22

Bonjour,

J'ai essayé ton code et ça marche parfaitement

merci beaucoup pour l'aide

Cordialement

Rechercher des sujets similaires à "date saisie inputbox connaitre heure mise"