Création d'une fonction via VBA

Version imprimable

07/10/2015, 20h00
a.ouguerzam

Création d'une fonction via VBA

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.

1 pièce(s) jointe(s)

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

Code:

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

08/10/2015, 14h25
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
08/10/2015, 15h23
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

Citation:

Envoyé par 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.

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:

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

09/10/2015, 15h23
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:

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

C'est possible ?

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

Code:

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:

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

12/10/2015, 13h49
a.ouguerzam
j'ai un message d'erreur d'exécution '1004' sur la ligne ci dessous :

Code:

Set ref1 = ref2.Offset(, -1)

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

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

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

Code:

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

Citation:

Envoyé par a.ouguerzam

Code:

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:

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