XL 2016 [RESOLU] Recherche d'une date dans VBA

Jojoye

XLDnaute Nouveau
Bonjour à toutes et à tous,

J'ai besoin de votre aide pour une recherche de date
Après de longue recherche sur le net, j'ai testé un code qui fonctionne lorsque je le renseigne manuellement dans SUB, si je pars d'une date que la macro va cherché sur une feuille, ce code ne fonctionne plus.
je joins également une partie du fichier
Voici le code :

Code:
Dim TempDate
Dim CibleLig As Double
Dim CibleCol As Double

Sub Actualiser_Ouvrier()
    '''Nom de la feuille active
    OngletOuvrier = ActiveSheet.Name
  
    Dim Ouvrier As String
    Dim NumLig As Double
    Dim NumLigSuiv As Double
    Dim DerCol As Double
    Dim DerLigPlann As Double
    Dim TempChantier As String
    'Dim TempDate As String
  
    Ouvrier = Sheets(OngletOuvrier).Range("B3")
    NumLig = Sheets("2021").Range("A:A").Find(What:=Ouvrier, lookat:=xlWhole).Row + 1
    DerLigPlann = Sheets("2021").Cells(Rows.Count, 1).End(xlUp).Row
  
    For i = NumLig To DerLigPlann
        DerCol = Sheets("2021").Cells(NumLig, Columns.Count).End(xlToLeft).Column
      
        If Sheets("2021").Cells(NumLig, 1) = "" Then
            TempChantier = Sheets("2021").Cells(NumLig, DerCol)
            TempDate = Sheets("2021").Cells(2, DerCol).Value
            NumLig = NumLig + 1
        Else
            Exit For
        End If
    Next i
  
    '''Recherche de la date
    Ch_LaDate
  
End Sub

''''Fonctionne avec la date "11/01/2021" mais pas avec TempDate
Sub Ch_LaDate()
    Dim RechToday As Date
    Dim Cible As Range
    Dim Plage As Range
  
    RechToday = CDate("11/01/2021") 'Fonctionne
    'RechToday = CDate(TempDate) 'Ne fonctionne pas

    Set Cible = Sheets("2021 Claude").Cells.Find(What:=RechToday, lookat:=xlWhole)
  
    If Not Cible Is Nothing Then
        MsgBox Cible.Value & " dans la cellule " & Cible.Address
        CibleLig = Cible.Row
        CibleCol = Cible.Column
        MsgBox "ligne = " & CibleLig & " colonne = " & CibleCol
    Else
        MsgBox "date : " & Today & " introuvable"
    End If

End Sub
 

Pièces jointes

  • Planning chantiers.xlsm
    249.7 KB · Affichages: 3
Dernière édition:
Haut Bas