Changer date sur projet VBA existant

Bonjour,

j'ai récupéré sur internet un classeur excel interressant. Il est programmé en VBA avec un fichier recherche associé au classeur.
je n'arrive pas à actualiser la date dans la macro sur le bouton "selectionner les aliments" dans la feuille "valeurs en points". les dates restent sur 2006

j'ai cherché ++++, il me mets à chaque fois erreur "1004"......
Merci pour votre aideJe crois que cela doit se situer dans (If IsDate(ComboBox3.Value))
Je ne sais pas joindre un fichier, j'ai pas trouvé....
je vous donne donc le code VBA sur la feuille recherche:
'---------------------------------------------------------------------------------------
' Module : recherchedmos
' DateTime : 06/04/2006 17:07
' Author : JP14
' Purpose : usf recherche
'---------------------------------------------------------------------------------------

Option Explicit


'nom des feuilles
Const nomfeuille1 As String = "Feuil1"
Const nomfeuille2 As String = "Valeur en points"
Const nomfeuille3 As String = "synthese"

' déclaration des variables
Dim anval1 As String
Dim colonne2a As String
Dim i As Long
Dim data1 As String
Dim data2 As String
Dim trouve As Byte
Dim erreur As Byte
'
'=========================================
Dim Flag As Integer

Dim j As Long
Dim j1 As Long
Dim ligne As Long
Dim dl2 As Long
Dim dl3 As Long

Dim total As Double
Dim poids As Double
Dim ligne1 As Long


'---------------------------------------------------------------------------------------
' Procedure : ComboBox1_Change
' DateTime : 18/12/2006 19:09
' Author : jp14
' Pour : http://www.excel-downloads
' Utilisation : remplissage et visualisation de la liste Nature
'---------------------------------------------------------------------------------------
'
Private Sub ComboBox1_Change()

ComboBox2.Clear
If Flag = 1 Then Exit Sub ' pour éviter une éxécution lors de
'la construction de la liste
'préparation du deuxième combobox
' position du curseur dans le comobobox suivant
rempcombobox2
Flag = 0
ComboBox2.Visible = True
Label2.Visible = True
ComboBox2.SetFocus

End Sub

'---------------------------------------------------------------------------------------
' Procedure : ComboBox2_Change
' DateTime : 18/12/2006 19:14
' Author : jp14
' Pour : http://www.excel-downloads
' Utilisation : recherche des informations unité quantité points et affichage
'---------------------------------------------------------------------------------------
'
Private Sub ComboBox2_Change()

colonne2a = "A"
data1 = ComboBox1.Text
data2 = ComboBox2.Text
i = rechercheligne(nomfeuille2, "A", data1 & data2, 2, 4)
If i > 0 Then
Label6.Caption = Sheets(nomfeuille2).Range(colonne2a & i).Offset(0, 2)
Label7.Caption = Sheets(nomfeuille2).Range(colonne2a & i).Offset(0, 3)
Label8.Caption = Sheets(nomfeuille2).Range(colonne2a & i).Offset(0, 4)
Label6.Visible = True
Label7.Visible = True
Label8.Visible = True

Label4.Visible = True
Label5.Visible = True
End If
End Sub





'---------------------------------------------------------------------------------------
' Procedure : ComboBox3_AfterUpdate
' DateTime : 20/12/2006 19:17
' Author : jp14
' Pour : http://www.excel-downloads
' Utilisation :
'---------------------------------------------------------------------------------------
'
Private Sub ComboBox3_AfterUpdate()
If IsDate(ComboBox3.Value) Then
Else
MsgBox " date non conforme"
Exit Sub
End If
ligne1 = rechercheligne(nomfeuille3, colonne2a, ComboBox3.Value, 1, 2)
TextBox1.Value = Sheets(nomfeuille3).Cells(ligne1, 1).Offset(0, 1)
Label13.Caption = Sheets(nomfeuille3).Cells(ligne1, 1).Offset(0, 2)

If ligne1 > 2 Then
Label11.Caption = Sheets(nomfeuille3).Cells(ligne1 - 1, 1).Offset(0, 1)
Label12.Caption = Sheets(nomfeuille3).Cells(ligne1 - 1, 1)
Label12.Visible = True
Label11.Visible = True
Label15.Visible = True
Else
Label12.Visible = False
Label11.Visible = False
Label15.Visible = False
End If
End Sub

Private Sub ComboBox3_Change()


End Sub

'---------------------------------------------------------------------------------------
' Procedure : CommandButton1_Click
' DateTime : 18/12/2006 19:26
' Author : jp14
' Pour : http://www.excel-downloads
' Utilisation : quitter
'---------------------------------------------------------------------------------------
'
Private Sub CommandButton1_Click()
Dim data2 As String
effacer
trier
' ecriture des totaux partiels
Sheets(nomfeuille2).Activate
data1 = ""
dl2 = Sheets(nomfeuille1).Range(colonne2a & "65536").End(xlUp).Row

For i = 2 To dl2

If data1 = Sheets(nomfeuille1).Range(colonne2a & i) & Sheets(nomfeuille1).Range(colonne2a & i).Offset(0, 1) Then

Sheets(nomfeuille1).Cells(i, 7) = Sheets(nomfeuille1).Cells(i - 1, 7) + Sheets(nomfeuille1).Cells(i, 6)
Else
Sheets(nomfeuille1).Cells(i, 7) = Sheets(nomfeuille1).Cells(i, 6)
End If
data1 = Sheets(nomfeuille1).Range(colonne2a & i) & Sheets(nomfeuille1).Range(colonne2a & i).Offset(0, 1)
Next i
' ecriture total
data1 = ""

For i = 2 To dl2
data2 = Sheets(nomfeuille1).Range(colonne2a & i)
ligne1 = rechercheligne(nomfeuille3, colonne2a, data2, 1, 2)

If data1 = data2 Then
Sheets(nomfeuille1).Cells(i, 8) = Sheets(nomfeuille1).Cells(i - 1, 8) + Sheets(nomfeuille1).Cells(i, 6)
Else
Sheets(nomfeuille1).Cells(i, 8) = Sheets(nomfeuille1).Cells(i, 6)
total = 0
End If

data1 = Sheets(nomfeuille1).Range(colonne2a & i)

If Sheets(nomfeuille1).Cells(i, 8) > total Then total = Sheets(nomfeuille1).Cells(i, 8)

If ligne1 > 0 Then Sheets(nomfeuille3).Cells(ligne1, 1).Offset(0, 2) = total

Next i
'on efface le graphique

Worksheets(nomfeuille3).ChartObjects.Delete



'création du graphique
dl2 = Sheets(nomfeuille3).Range(colonne2a & "65536").End(xlUp).Row
Sheets("synthese").Select
Charts.Add
ActiveChart.ChartType = xlLine
ActiveChart.SetSourceData Source:=Sheets("synthese").Range("B1:C" & dl2), PlotBy _
:=xlColumns
ActiveChart.SeriesCollection(1).XValues = "=synthese!R2C1:R" & dl2 & "C1"
ActiveChart.SeriesCollection(2).XValues = "=synthese!R2C1:R" & dl2 & "C1"
ActiveChart.Location Where:=xlLocationAsObject, Name:="synthese"
With ActiveChart
.HasTitle = False
.Axes(xlCategory, xlPrimary).HasTitle = False
.Axes(xlValue, xlPrimary).HasTitle = False
End With

Unload recherche

End Sub


'---------------------------------------------------------------------------------------
' Procedure : CommandButton10_Click
' DateTime : 19/12/2006 13:30
' Author : jp14
' Pour : http://www.excel-downloads
' Utilisation :effacer la journée
'---------------------------------------------------------------------------------------
'
Private Sub CommandButton10_Click()
Dim ligne1 As Long

If IsDate(ComboBox3.Value) Then
Else
MsgBox " date non conforme"
Exit Sub
End If
' recherche de la première ligne à imprimer
dl2 = Sheets(nomfeuille1).Range(colonne2a & "65536").End(xlUp).Row
For i = 2 To dl2
ligne1 = rechercheligne(nomfeuille1, "A", ComboBox3.Value, 1, i)
If ligne1 <> 0 Then
Sheets(nomfeuille1).Rows(ligne1 & ":" & ligne1).ClearContents
End If
Next i
End Sub

'---------------------------------------------------------------------------------------
' Procedure : CommandButton4_Click
' DateTime : 19/12/2006 13:28
' Author : jp14
' Pour : http://www.excel-downloads
' Utilisation :imprimer
'---------------------------------------------------------------------------------------
'
Private Sub CommandButton4_Click()
Dim ligne1 As Long

If IsDate(ComboBox3.Value) Then
Else
MsgBox " date non conforme"
Exit Sub
End If
' recherche de la première ligne à imprimer
ligne1 = rechercheligne(nomfeuille1, "A", ComboBox3.Value, 1, 2)
dl2 = Sheets(nomfeuille1).Range(colonne2a & "65536").End(xlUp).Row
For i = ligne1 + 1 To dl2
If rechercheligne(nomfeuille1, "A", ComboBox3.Value, 1, i) = 0 Then
Exit For
End If
Next i
'i contient la dernière ligne
Sheets("Feuil1").Select
Range("A" & ligne1 & ":I" & (i - 1)).Select
ActiveSheet.PageSetup.PrintArea = "$A$2:$I$6"
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$1"
.PrintTitleColumns = ""
End With
With ActiveSheet.PageSetup
.Orientation = xlLandscape
.FitToPagesWide = 1
.FitToPagesTall = 5

End With
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
End Sub

'---------------------------------------------------------------------------------------
' Procedure : CommandButton6_Click
' DateTime : 19/12/2006 13:29
' Author : jp14
' Pour : http://www.excel-downloads
' Utilisation : remise à zéro
'---------------------------------------------------------------------------------------
'
Private Sub CommandButton6_Click()
ComboBox3.Clear
ComboBox1.Clear
UserForm_Initialize
End Sub

'---------------------------------------------------------------------------------------
' Procedure : CommandButton9_Click
' DateTime : 18/12/2006 19:27
' Author : jp14
' Pour : http://www.excel-downloads
' Utilisation : mise à jour sauf si pas de sélection

'---------------------------------------------------------------------------------------
'
Private Sub CommandButton9_Click()
Dim ligne1 As Long

' contrôle
If IsDate(ComboBox3.Value) Then
Else
MsgBox " date non conforme"
Exit Sub
End If

If TextBox1.Value <> "" Then
If IsNumeric(TextBox1.Value) Then
poids = TextBox1.Value
Else
MsgBox " Poids non conforme (ecriture)"
End If

End If


If OptionButton1.Value = False _
And OptionButton2.Value = False _
And OptionButton3.Value = False _
Then
MsgBox " il faut sélectionner un repas "
erreur = 1
Exit Sub
End If
' fin des contrôles
'*********************************************************

If ComboBox2.Value <> "" Then
' recherche de la ligne
ligne1 = rechercheligne(nomfeuille2, "A", ComboBox1.Value & ComboBox2.Value, 2, 2)
colonne2a = "A"
dl2 = Sheets(nomfeuille1).Range(colonne2a & "65536").End(xlUp).Row + 1
i = 0
j = 0
Sheets(nomfeuille1).Range(colonne2a & dl2).Offset(0, j) = ComboBox3.Value
j = j + 1
If OptionButton1.Value = True Then
Sheets(nomfeuille1).Range(colonne2a & dl2).Offset(0, j) = "matin"
End If
If OptionButton2.Value = True Then
Sheets(nomfeuille1).Range(colonne2a & dl2).Offset(0, j) = "midi"
End If
If OptionButton3.Value = True Then
Sheets(nomfeuille1).Range(colonne2a & dl2).Offset(0, j) = "soir"
End If
j = j + 1
Sheets(nomfeuille1).Range(colonne2a & dl2).Offset(0, j) = Sheets(nomfeuille2).Range(colonne2a & ligne1).Offset(0, i)
j = j + 1
i = i + 1
Sheets(nomfeuille1).Range(colonne2a & dl2).Offset(0, j) = Sheets(nomfeuille2).Range(colonne2a & ligne1).Offset(0, i)
j = j + 1
i = i + 2
Sheets(nomfeuille1).Range(colonne2a & dl2).Offset(0, j) = Sheets(nomfeuille2).Range(colonne2a & ligne1).Offset(0, i)
j = j + 1 ' 5
i = i + 1
Sheets(nomfeuille1).Range(colonne2a & dl2).Offset(0, j) = Sheets(nomfeuille2).Range(colonne2a & ligne1).Offset(0, i)
j = j + 1
i = i + 1
Sheets(nomfeuille1).Range(colonne2a & dl2).Offset(0, j) = Sheets(nomfeuille2).Range(colonne2a & ligne1).Offset(0, i)
j = j + 1
i = i + 1
Sheets(nomfeuille1).Range(colonne2a & dl2).Offset(0, i) = Sheets(nomfeuille2).Range(colonne2a & ligne1).Offset(0, i)
j = j + 1
i = i + 1

End If
'***************************************************************

' feuille synthése

ligne1 = rechercheligne(nomfeuille3, colonne2a, ComboBox3.Value, 1, 2)
dl2 = Sheets(nomfeuille3).Range(colonne2a & "65536").End(xlUp).Row + 1

If ligne1 = 0 Then
Sheets(nomfeuille3).Cells(dl2, 1) = ComboBox3.Value
If poids > 0 Then Sheets(nomfeuille3).Cells(dl2, 1).Offset(0, 1) = poids
Else
If poids > 0 Then Sheets(nomfeuille3).Cells(ligne1, 1).Offset(0, 1) = poids
End If

End Sub

'---------------------------------------------------------------------------------------
' Procedure : OptionButton1_Click
' DateTime : 19/12/2006 14:19
' Author : jp14
' Pour : http://www.excel-downloads
' Utilisation : bouton radio
'---------------------------------------------------------------------------------------
'
Private Sub OptionButton1_Click()
If erreur = 1 Then erreur = 0: Exit Sub
ComboBox2.Clear
ComboBox1.Clear
UserForm_Initialize
End Sub

Private Sub OptionButton2_Click()
OptionButton1_Click
End Sub

Private Sub OptionButton3_Click()
OptionButton1_Click
End Sub

'------------------------------------------------------------------------
' Macro : UserForm_Initialize
' DateTime : 07/04/2006 09:46
' Author : JP14
' Purpose :
'' Initialisation
'
'------------------------------------------------------------------------
Private Sub UserForm_Initialize()

ligne = 0

colonne2a = "A"

rempcombobox1
ComboBox2.Visible = False
Label2.Visible = False

rempcombobox3
Label4.Visible = False
Label6.Visible = False
Label7.Visible = False
Label5.Visible = False
Label8.Visible = False
Label2.Visible = False
Label12.Visible = False
Label11.Visible = False
Label15.Visible = False

End Sub

'*************************************************************************
' sous programmes
'
'*************************************************************************
'
'
'
'
'
'
'
'
'
'
'
'
'
'
'-----------------------------------------------------------------------------------
'
'---------------------------------------------------------------------------------------
' Procedure : rempcombobox1
' DateTime : 18/12/2006 19:07
' Author : jp14
' Pour : http://www.excel-downloads
' Utilisation : remplir le combobox 1
'---------------------------------------------------------------------------------------
Private Sub rempcombobox1()

data1 = ""
dl2 = Sheets(nomfeuille2).Range(colonne2a & "65536").End(xlUp).Row
ComboBox1.AddItem data1
For i = 2 To dl2

If data1 <> Sheets(nomfeuille2).Range(colonne2a & i) Then
Flag = 1
ComboBox1.AddItem Sheets(nomfeuille2).Range(colonne2a & i)
data1 = Sheets(nomfeuille2).Range(colonne2a & i)
Flag = 0
End If
Next i
Flag = 0
End Sub

'---------------------------------------------------------------------------------------
' Procedure : rempcombobox2
' DateTime : 18/12/2006 19:59
' Author : jp14
' Pour : http://www.excel-downloads
' Utilisation :
'---------------------------------------------------------------------------------------
'
Private Sub rempcombobox2()

ComboBox2.AddItem ""
data1 = ComboBox1.Text
dl2 = Sheets(nomfeuille2).Range(colonne2a & "65536").End(xlUp).Row
For i = 2 To dl2

If data1 = Sheets(nomfeuille2).Range(colonne2a & i) Then
Flag = 1
ComboBox2.AddItem Sheets(nomfeuille2).Range(colonne2a & i).Offset(0, 1)
Flag = 0
End If
Next i
Flag = 0
End Sub
'---------------------------------------------------------------------------------------
' Procedure : rempcombobox3
' DateTime : 18/12/2006 19:59
' Author : jp14
' Pour : http://www.excel-downloads
' Utilisation :
'---------------------------------------------------------------------------------------
'
Private Sub rempcombobox3()

data1 = ""
dl2 = Sheets(nomfeuille1).Range(colonne2a & "65536").End(xlUp).Row
ComboBox3.AddItem data1

For i = 2 To dl2

If data1 <> Sheets(nomfeuille1).Range(colonne2a & i) Then
Flag = 1
ComboBox3.AddItem Sheets(nomfeuille1).Range(colonne2a & i)
data1 = Sheets(nomfeuille1).Range(colonne2a & i)
Flag = 0
End If
Next i
Flag = 0
End Sub
'---------------------------------------------------------------------------------------
' Procedure : trier
' DateTime : 18/12/2006 20:11
' Author : jp14
' Pour : http://www.excel-downloads
' Utilisation :
'---------------------------------------------------------------------------------------
'
Private Sub trier()
'
Sheets(nomfeuille1).Select
Cells.Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
:=xlSortNormal
End Sub
'---------------------------------------------------------------------------------------
' Procedure : effacer
' DateTime : 18/12/2006 20:11
' Author : jp14
' Pour : http://www.excel-downloads
' Utilisation :
'---------------------------------------------------------------------------------------
'
Private Sub effacer()
Dim dl2 As Long
dl2 = Sheets(nomfeuille1).Range(colonne2a & "65536").End(xlUp).Row
'
Sheets(nomfeuille1).Select
Range("H2:I" & dl2).Select
Selection.ClearContents

End Sub

'---------------------------------------------------------------------------------------
' Procedure : rechercheligne
' DateTime : 19/12/2006 13:34
' Author : jp14
' Pour : http://www.excel-downloads
' Utilisation :fonction pour rechercher une ligne contenant un texte
'feuille As String feuile qui contient les données
'colonne As string numéro de colonne
'dataf As String valeur à chercher
'nbcol As Integer nombre de colonne adjacente
'depart As Long ligne de depart
'rechercheligne(feuille, colonne, dataf, nbcol, depart)
'
'---------------------------------------------------------------------------------------
'
Private Function rechercheligne(feuille As String, colonne As String, dataf As String, nbcol As Integer, depart As Long)
Dim dataf1 As String
Dim if1 As Integer
Dim if2 As Long


dl2 = Sheets(feuille).Range(colonne & "65536").End(xlUp).Row
For if2 = depart To dl2
dataf1 = ""
If nbcol > 1 Then
For if1 = 1 To nbcol
dataf1 = dataf1 & Sheets(feuille).Range(colonne & if2).Offset(0, if1 - 1)
Next if1
Else
dataf1 = dataf1 & Sheets(feuille).Range(colonne & if2)
End If

If dataf = dataf1 Then
rechercheligne = if2
Exit Function
End If
Next if2
rechercheligne = 0
End Function