Changer date sur projet VBA existant [Résolu/Fermé]

Messages postés
49
Date d'inscription
mardi 30 octobre 2007
Statut
Membre
Dernière intervention
18 septembre 2011
- - Dernière réponse : michel_m
Messages postés
16002
Date d'inscription
lundi 12 septembre 2005
Statut
Contributeur
Dernière intervention
5 décembre 2019
- 19 sept. 2011 à 08:43
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


Afficher la suite 

5 réponses

Messages postés
16002
Date d'inscription
lundi 12 septembre 2005
Statut
Contributeur
Dernière intervention
5 décembre 2019
2833
0
Merci
bonjour,

apparemment, l'événement "afterupdate" n'existe pas sur Excel pour un combobox

mais le mieux serait de demander sur le forum d'où vient ce site !
Messages postés
49
Date d'inscription
mardi 30 octobre 2007
Statut
Membre
Dernière intervention
18 septembre 2011
0
Merci
Merci de m'avoir éclairé, j'ai effectivement posté un message sur le site concerné, mais comme l'origine de ces fichiers est ancienne (2006)

que je suis inscrit depuis longtemps sur "comment ça marche"

et que vous m'avez toujours solutionné mes problèmes .......
j'ai essayé de voir si vous aviez vous aussi une solution
Merci encore

je clos le sujet
0
Merci
Pour michel_m, l'événement "afterupdate" existe bien pour un combobox, si le combobox se trouve sur une Userform.

Sans le classeur pas facile de voir le problème, ce qui amène une question déontologique :

peut-on modifier le code de quelqu'un sans son aval, m^me si le dit code est déposé sur un site en libre téléchargement ?
Messages postés
49
Date d'inscription
mardi 30 octobre 2007
Statut
Membre
Dernière intervention
18 septembre 2011
0
Merci
Bonjour
je suis d'accord avec votre approche déontologique, mais il me semble après relecture de la discussion que l'auteur à fait ce code dans le but d'aider la personne et d'autres personnes sur ce fichier.
vous trouverez ci-dessous le lien de la discussion afin que vous puissiez faire votre propre opinion.

http://www.excel-downloads.com/forum/72375-regime-weight-watcher-en-tableau.html

Avec ce lien vous disposerez des deux fichiers concernés par ma question:
Menuv3.zip et recherche .zip

mais si après lecture cela vous gêne de modifier ce code, je comprendrai
Cordialement
Messages postés
16002
Date d'inscription
lundi 12 septembre 2005
Statut
Contributeur
Dernière intervention
5 décembre 2019
2833
0
Merci
Bonjour,
Effectivement, Paf, j'avais dessiné le combo sur une feuille... Merci

Par contre, lorsque l'on met une appli sur un forum, la seule "redevance" souhaitée est de citer l'auteur et le forum ou le site où on a trouvé lsa solution.

Mais rien n'empêche d'envoyer à l'auteur un coucou de remerciement (action de + en + rare)

de plus, on ne peut rien faire contre le voyou qui s'approprie une appli pour un forum en shareware comme ça m'est arrivé :o((
Michel