Discussion :

[a.ouguerzam]

Bonjour,

Je suis en train d’essayé de mettre une formule en VBA qui me permet de calcule combien d’année passée entre la date d’aujourd’hui et une date fixé et la date fixé ce trouve toujours dans la dernier colonne remplis.
La formule et la suite : (Date d’aujourd’hui()-date indique dans la dernier colonne remplis/30/12) et j’aime mettre le résultats dans la dernier colonne vide
Quelqu’un peut m’aide à mettre cette fonction sur VBA.

merci d'avance pour votre aide.

[kiki29]

Salut, un exemple plus large, à toi de l'adapter à ton contexte

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
Function DiffDateAMJ(DateDebut As Date, DateFin As Date) As String
Dim NbAns As Long, NbMois As Long, NbJours As Long
Dim Tmp As Date
    Tmp = DateSerial(Year(DateFin), Month(DateDebut), Day(DateDebut))
    NbAns = Year(DateFin) - Year(DateDebut) + (Tmp > DateFin)
    NbMois = Month(DateFin) - Month(DateDebut) - (12 * (Tmp > DateFin))
    NbJours = Day(DateFin) - Day(DateDebut)    ' + 1
    If NbJours < 0 Then
        NbMois = NbMois - 1
        NbJours = Day(DateSerial(Year(DateFin), Month(DateFin), 0)) + NbJours
    End If
    DiffDateAMJ = NbAns & "a " & NbMois & "m " & NbJours & "j"
End Function

[a.ouguerzam]

j'ai bien aimé ton code surtout résultats final avec combien de jour du mois et année merci bcq je vais essaye de l'adapté avec mon code déjà réalisé sur le fichier par ce que j'ai des conditions a respecte de me mettre les resultats dans la dernier colonne vide après application du 1er code qui mette les résultats aussi sur la dernier colonne vide

[a.ouguerzam]

ouh je suis desole les amis j'ai passe tout la matinée a cherche sur des forums pour adapté le code mais vraiment j'arrive pas je suis vraiment novice

[Docmarti]

Bonjour,

Je suis en train d’essayé de mettre une formule en VBA qui me permet de calcule combien d’année passée entre la date d’aujourd’hui et une date fixé et la date fixé ce trouve toujours dans la dernier colonne remplis.
La formule et la suite : (Date d’aujourd’hui()-date indique dans la dernier colonne remplis/30/12) et j’aime mettre le résultats dans la dernier colonne vide
Quelqu’un peut m’aide à mettre cette fonction sur VBA.

merci d'avance pour votre aide.

Tu peux enlever toutes les lignes qui contiennent .Select. Car elles ne servent à rien d'autre qu'à vérifier que le code est bon.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
Sub AujourdhuiMoinsLaDate()
 
Set f = ActiveSheet 'ou Worksheets("Feuil1")
f.Select
dernligne = f.Cells(Rows.Count, 1).End(xlUp).Row
 
Set rg = f.Cells.Find(what:="*", After:=f.Cells(1, 1), LookIn:=xlValues, LookAt:=xlPart, SearchFormat:=False, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
 If Not rg Is Nothing Then
  dernColonne = rg.Column
 Else
  MsgBox "Il y a un probleme"
  Exit Sub
 End If
 
Set r = f.Range(f.Cells(1, dernColonne + 1), f.Cells(dernligne, dernColonne + 1))
r.Select
r.NumberFormat = "General"
 
Set premier = r.Cells(1, 1)
premier.Select
Set ref = premier.Offset(, -1)
ref.Select
addr = ref.Address(RowAbsolute:=False, columnabsolute:=False)
premier.FormulaLocal = "=AUJOURDHUI()-" & addr
premier.AutoFill Destination:=r, Type:=xlFillDefault
r.Select
r.FormulaLocal = r.Value 'Remplace les formules par les valeurs
End Sub

[a.ouguerzam]

ca marche très bien il me donne combien de jour je peux rajouter a la fonction une petite modification pour avoir combien d'année

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

premier.FormulaLocal = "=AUJOURDHUI()-" & addr / 30 /12

C'est possible ?

[Docmarti]

Ca a l'air possible en divisant les jours par 365,25 :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
formule = "AUJOURDHUI()-" & addr
formule = "=ent((" & formule & ")/365,25)"
premier.FormulaLocal = formule

La division en VBA par 365.25 n'est pas une solution parfaite. En fait, sur 8000 dates consécutives sur lesquelles est exécuté cette division, il y a 12 résultats inexacts avec une erreur de 1.

Mais on peut se servir de la fonction de feuille DateDif dans Excel qui ne produit pas d'erreurs.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
Sub AujourdhuiMoinsLaDate()
 
Set f = ActiveSheet 'ou Worksheets("Feuil1")
f.Select
dernligne = f.Cells(Rows.Count, 1).End(xlUp).Row
 
Set rg = f.Cells.Find(what:="*", After:=f.Cells(1, 1), LookIn:=xlValues, LookAt:=xlPart, SearchFormat:=False, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
 If Not rg Is Nothing Then
  dernColonne = rg.Column
 Else
  MsgBox "Il y a un probleme"
  Exit Sub
 End If
 
Set r = f.Range(f.Cells(1, dernColonne + 1), f.Cells(dernligne, dernColonne + 1))
r.Select
r.NumberFormat = "General"
Set premier = r.Cells(1, 1)
premier.Select
Set ref2 = premier.Offset(, -1)
ref2.Select
addr2 = ref2.Address(RowAbsolute:=False, columnabsolute:=False)
Set ref1 = ref2.Offset(, -1)
ref1.Select
addr1 = ref1.Address(RowAbsolute:=False, columnabsolute:=False)
 
'Formule à générer   =DATEDIF(H4;I4;"y")
formule = "=DATEDIF(" & addr1 & ";" & addr2 & ";" & """y""" & ")"
 
premier.FormulaLocal = formule
premier.AutoFill Destination:=r, Type:=xlFillDefault
r.Select
 Stop
r.FormulaLocal = r.Value 'Remplace les formules par les valeurs
End Sub

[a.ouguerzam]

j'ai un message d'erreur d'exécution '1004' sur la ligne ci dessous :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Set ref1 = ref2.Offset(, -1)

mais avec le code ci dessous ça marche très bien :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
formule = "AUJOURDHUI()-" & addr
formule = "=ent((" & formule & ")/365,25)"
premier.FormulaLocal = formule

[a.ouguerzam]

salut les amis le code ça marche avec la combinaison ci dessous merci bcq de votre aide :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
Sub AujourdhuiMoinsLaDate()
 
Set f = ActiveSheet 'ou Worksheets("Feuil1")
f.Select
dernligne = f.Cells(Rows.Count, 1).End(xlUp).Row
 
Set rg = f.Cells.Find(what:="*", After:=f.Cells(1, 1), LookIn:=xlValues, LookAt:=xlPart, SearchFormat:=False, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
 If Not rg Is Nothing Then
  dernColonne = rg.Column
 Else
  MsgBox "Il y a un probleme"
  Exit Sub
 End If
 
Set r = f.Range(f.Cells(1, dernColonne + 1), f.Cells(dernligne, dernColonne + 1))
r.Select
r.NumberFormat = "General"
 
Set premier = r.Cells(1, 1)
premier.Select
Set ref = premier.Offset(, -1)
ref.Select
addr = ref.Address(RowAbsolute:=False, columnabsolute:=False)
formule = "AUJOURDHUI()-" & addr
formule = "=ent((" & formule & ")/30/12)"
premier.FormulaLocal = formule
premier.AutoFill Destination:=r, Type:=xlFillDefault
r.Select
r.FormulaLocal = r.Value 'Remplace les formules par les valeurs
End Sub

[Docmarti]

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
Set premier = r.Cells(1, 1)
premier.Select
Set ref = premier.Offset(, -1)
ref.Select
addr = ref.Address(RowAbsolute:=False, columnabsolute:=False)
formule = "AUJOURDHUI()-" & addr
formule = "=ent((" & formule & ")/30/12)"
premier.FormulaLocal = formule
premier.AutoFill Destination:=r, Type:=xlFillDefault

Diviser par /30/12 revient à diviser par 360.
Ce serait mieux de diviser par 365.25

Si tu veux utiliser la fonction DateDif sur la feuille pour comparer les dates avec AUJOURDHUI(), voici :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
Sub tt()
 
Set f = ActiveSheet 'ou Worksheets("Feuil1")
 
With f.Cells
 
 Set rg = .Find(what:="*", After:=.Cells(1, 1), LookIn:=xlValues, LookAt:=xlPart, SearchFormat:=False, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
 If Not rg Is Nothing Then
  derniereColonne = rg.Column
 Else
  MsgBox "Il y a un probleme"
  Exit Sub
 End If
 
End With
 
dern = f.Cells(Rows.Count, 1).End(xlUp).Row
 
Set r = f.Range("A1:A" & dern)
 
For i = 1 To dern
 Set c = f.Cells(i, 1)
 
 If Trim(c.Value) = "" Then
 Else
  t = Split(c.Value, "/")
  If UBound(t) = 2 Then
   converti = t(1) & "/" & t(0) & "/" & t(2)
   Set dest = f.Cells(c.Row, derniereColonne + 1)
   dest.NumberFormat = "m/d/yyyy"
   dest.FormulaLocal = converti
   d = TypeName(dest.Value)
   If premier = "" Then
    premier = d
   Else
    If d <> premier Then
     dest.Select
     MsgBox "Probleme potentiel ici. Types de donnees differents"
    End If
   End If
  End If
 End If
Next
Call AujourdhuiMoinsLaDate(f)
End Sub
 
Sub AujourdhuiMoinsLaDate(f)
 
dernligne = f.Cells(Rows.Count, 1).End(xlUp).Row
 
Set rg = f.Cells.Find(what:="*", After:=f.Cells(1, 1), LookIn:=xlValues, LookAt:=xlPart, SearchFormat:=False, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
 If Not rg Is Nothing Then
  dernColonne = rg.Column
 Else
  MsgBox "Il y a un probleme"
  Exit Sub
 End If
 
Set r = f.Range(f.Cells(1, dernColonne + 1), f.Cells(dernligne, dernColonne + 1))
r.NumberFormat = "General"
Set premier = r.Cells(1, 1)
 
Set ref2 = premier.Offset(, 1)
ref2.FormulaLocal = "=AUJOURDHUI()"
addr2 = ref2.Address(RowAbsolute:=True, columnabsolute:=True)
 
Set ref1 = premier.Offset(, -1)
addr1 = ref1.Address(RowAbsolute:=False, columnabsolute:=False)
 
formule = "=DATEDIF(" & addr1 & ";" & addr2 & ";" & """y""" & ")"
premier.FormulaLocal = formule
premier.AutoFill Destination:=r, Type:=xlFillDefault
 
 Stop
r.FormulaLocal = r.Value 'Remplace les formules par les valeurs
ref2.Formula = ""
End Sub