J'ai trouvé un tutoriel avec un fichier exemple pour avoir un calendrier qui apparaît plutot que de rentrer une date dans une InputBox.
Mais il y a quelque chose qui m'échappe.
En quoi :
Private Sub CommandButton1_Click()
Calendrier.Show
End Sub
Est différent de
Sub Calendrier()
Calendrier.Show
End Sub
Si je met sur un bouton? J'ai "Fonction ou variable attendue".
Je vous met tout le code si ca vous intéresse :
Sur le userform :
Option Explicit
Private Sub UserForm_Initialize()
Dim Obj As Control
Dim i As Integer, Mois As Integer, Annee As Integer
Dim Cl As ClasseBtnChange
'Création Boutons Changement de mois et d'année
Set Collect = New Collection
'BOUTONS :
'- < et > = mois
'- >> et << = année
Set Obj = Me.Controls.Add("forms.CommandButton.1")
With Obj
.Name = "AnneePrec"
.Object.Caption = "<<"
.Left = 27
.Top = 1
.Width = 20
.Height = 20
End With
Set Cl = New ClasseBtnChange
Set Cl.Bouton = Obj
Collect.Add Cl
Set Obj = Me.Controls.Add("forms.CommandButton.1")
With Obj
.Name = "MoisPrec"
.Object.Caption = "<"
.Left = 50
.Top = 1
.Width = 20
.Height = 20
End With
Set Cl = New ClasseBtnChange
Set Cl.Bouton = Obj
Collect.Add Cl
Set Obj = Me.Controls.Add("forms.CommandButton.1")
With Obj
.Name = "MoisSuiv"
.Object.Caption = ">"
.Left = 75
.Top = 1
.Width = 20
.Height = 20
End With
Set Cl = New ClasseBtnChange
Set Cl.Bouton = Obj
Collect.Add Cl
Set Obj = Me.Controls.Add("forms.CommandButton.1")
With Obj
.Name = "AnneeSuiv"
.Object.Caption = ">>"
.Left = 98
.Top = 1
.Width = 20
.Height = 20
End With
Set Cl = New ClasseBtnChange
Set Cl.Bouton = Obj
Collect.Add Cl
'Création entête Jours de la semaine
For i = 1 To 7
Set Obj = Me.Controls.Add("forms.Label.1")
With Obj
.Name = "Jour" & i
.Object.Caption = UCase(Left(Format(DateSerial(2014, 9, i), "dddd"), 1))
.Left = 20 * (i - 1) + 5
.Top = 25
.Width = 20
.Height = 10
End With
Next i
'création boutons "jours"
Mois = Month(Date)
MoisEnCours = Mois
Annee = Year(Date)
AnneeEnCours = Annee
CreationBoutonsJours Mois, Annee
If Left(Format(Date, "dd"), 1) = "0" Then Me.Controls("Bouton" & Format(Date, "d")).SetFocus Else Me.Controls("Bouton" & Format(Date, "dd")).SetFocus
Set Cl = Nothing
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Set CollecBtnJours = Nothing
Set Collect = Nothing
End Sub
Sur un module nommé "Fonctions" :
Option Explicit
Public Collect As Collection, CollecBtnJours As Collection
Public MoisEnCours As Integer, AnneeEnCours As Integer
'Procédure de création des boutons Jours
'en fonction de l'année et du mois "en cours"
Sub CreationBoutonsJours(Mois As Integer, Annee As Integer)
Dim Obj As Control
Dim Cls As ClasseBtnJours
Dim NbJours As Integer, T As Integer, Gauc As Integer, Coul As Long, i As Integer, Taille As Integer
'Suppression de tous les boutons de commande "Jours"
For Each Obj In calendrier.Controls
If Left(Obj.Name, 6) = "Bouton" Then calendrier.Controls.Remove Obj.Name
Next
'création des boutons jours en fonction de l'année et du mois "en cours"
Set CollecBtnJours = New Collection
NbJours = Day(DateSerial(Annee, Mois + 1, 1) - 1)
For i = 1 To NbJours
If i = 1 Then T = 35
Select Case UCase(Format(DateSerial(Annee, Mois, i), "dddd"))
Case "LUNDI"
Gauc = 0
If i <> 1 Then T = T + 20
Coul = 13037551
Case "MARDI"
Gauc = 20
Coul = 13037551
Case "MERCREDI"
Gauc = 40
Coul = 13037551
Case "JEUDI"
Gauc = 60
Coul = 13037551
Case "VENDREDI"
Gauc = 80
Coul = 13037551
Case "SAMEDI"
Gauc = 100
Coul = 3754751
Case "DIMANCHE"
Gauc = 120
Coul = 3754751
End Select
If EstJourFerie(DateSerial(Annee, Mois, i)) Or Paques(Annee) = DateSerial(Annee, Mois, i) Then Coul = 1627780
Set Obj = calendrier.Controls.Add("forms.CommandButton.1")
With Obj
.Name = "Bouton" & i
.Object.Caption = i
.Left = Gauc
.Top = T
.Width = 20
.Height = 20
.Object.BackColor = Coul
End With
If i = NbJours Then Taille = Obj.Top + Obj.Height + 20
Set Cls = New ClasseBtnJours
Set Cls.Btn = Obj
CollecBtnJours.Add Cls
Next i
With calendrier
.Caption = Format(DateSerial(AnneeEnCours, MoisEnCours, 1), "mmmm yyyy")
.Tag = MoisEnCours & "/" & AnneeEnCours
.Height = Taille
.Width = 145
End With
Set Cls = Nothing
End Sub
'Fonction qui retourne le jour férié en "String"
'utile pour les info-bulles au survol des jours fériés
Public Function QuelFerie(Jour As Date) As String
Dim maDate As Date
Dim a As Integer, m As Integer, j As Integer
maDate = Paques(Year(Jour))
If Jour = maDate Then QuelFerie = "Dimanche de Pâques": Exit Function
If Jour = CDate(maDate + 1) Then QuelFerie = "Lundi de Pâques": Exit Function
If Jour = CDate(maDate + 50) Then QuelFerie = "Lundi de Pentecôte": Exit Function
If Jour = CDate(maDate + 39) Then QuelFerie = "Jeudi de l'ascension": Exit Function
a = Year(Jour): m = Month(Jour): j = Day(Jour)
Select Case m * 100 + j
Case 101
QuelFerie = "Nouvel An": Exit Function
Case 501
QuelFerie = "Fête du travail": Exit Function
Case 508
QuelFerie = "Armistice (2ème guerre mondiale)": Exit Function
Case 714
QuelFerie = "Fête Nationale": Exit Function
Case 815
QuelFerie = "Assomption": Exit Function
Case 1101
QuelFerie = "Toussaint": Exit Function
Case 1111
QuelFerie = "Armistice (1ère guerre mondiale)": Exit Function
Case 1225
QuelFerie = "Noël": Exit Function
End Select
End Function
'SOURCES :
'http://blog.developpez.com/philben/p11458/vba-access/sagit-il-dun-jour-ferie
Public Function EstJourFerie(ByVal laDate As Date, Optional ByVal EstPentecoteFerie As Boolean = True) As Boolean
'Détermine si la date passée en argument est un jour férié (en France) ou non :
' 101 = 1er Janvier - 501 = 1er Mai - 508 = 8 Mai - 714 = 14 Juillet
' 815 = 15 Août - 1101 = 1er Novembre - 1111 = 11 Novembre - 1225 = 25 Décembre
' dPa = Lundi de Pâques - dAs = Jeudi de l'Ascension - dPe = Lundi de Pentecôte
'Remarque : Le lundi de Pentecôte est un jour férié mais parfois non chômé (EstPentecoteFerie = False dans ce cas)
'Philben - v1.0 - 2012 - Free to use
Static Annee As Integer, dPa As Date, dAs As Date, dPe As Date, bPe As Boolean
Dim a As Integer, m As Integer, j As Integer
a = Year(laDate): m = Month(laDate): j = Day(laDate)
Select Case m * 100 + j
Case 101, 501, 508, 714, 815, 1101, 1111, 1225
EstJourFerie = True
Case 323 To 614 '323: Date mini Lundi de Pâques - 614 : Date maxi Lundi de Pentecôte
If a <> Annee Or EstPentecoteFerie <> bPe Then
Annee = a: dPa = Paques(a) + 1: dAs = dPa + 38
bPe = EstPentecoteFerie: If bPe Then dPe = dPa + 49 Else dPe = #1/1/100#
End If
Select Case DateSerial(a, m, j): Case dPa, dAs, dPe: EstJourFerie = True: End Select
End Select
End Function
'SOURCES :
'http://blog.developpez.com/philben/p11431/vba-access/calculer-la-date-de-paques
Public Function Paques(ByVal an As Integer) As Date
'Calcul de la date du dimanche de Pâques à partir de l'année 325
'Performance par million d'appel :
' - Entre 325 et 1582 et entre 1900 et 2099 => 1/4 de seconde
' - Année supérieure à 1582 hors 1900 - 2099 => 1/2 de seconde
'Philben - v1.0 - Free to use
Dim a As Integer, b As Integer, c As Integer, d As Integer, e As Integer, f As Integer
If an < 10000 Then 'Limite supérieure des dates sous Access (31 décembre 9999)
Select Case an
Case 1900 To 2099 'Algorithme de Carter
a = (204 - 11 * (an Mod 19)) Mod 30 + 22
Paques = DateSerial(an, 3, a + 6 + (a > 49) - (an + an \ 4 + a + (a > 49)) Mod 7)
Case Is > 1582 'Proposé en 1876 dans la revue Nature (dérivé de l'algorithme de Delambre)
a = an Mod 19: b = an \ 100: c = an Mod 100
d = (19 * a + b - b \ 4 - (b - (b + 8) \ 25 + 1) \ 3 + 15) Mod 30
e = (32 + 2 * (b Mod 4) + 2 * (c \ 4) - d - c Mod 4) Mod 7
f = d + e - 7 * ((a + 11 * d + 22 * e) \ 451) + 114
Paques = DateSerial(an, f \ 31, f Mod 31 + 1)
Case Is > 324 'Algorithme de Oudin pour les dates juliennes < 1583 décrit par Claus Tondering
a = (19 * (an Mod 19) + 15) Mod 30
Paques = DateSerial(an, 3, 28 + a - (an + an \ 4 + a) Mod 7)
End Select
End If
End Function
Sur un module de classe :
Public WithEvents Bouton As MSForms.CommandButton
'Module de classe pour les boutons : << < > >>
Private Sub Bouton_Click()
Select Case Bouton.Name
Case "AnneePrec"
AnneeEnCours = AnneeEnCours - 1
If AnneeEnCours = 1899 Then
MoisEnCours = 1
AnneeEnCours = 1900
MsgBox "Première année : 1900"
End If
Case "MoisPrec"
MoisEnCours = MoisEnCours - 1
If MoisEnCours = 0 Then
MoisEnCours = 12
AnneeEnCours = AnneeEnCours - 1
If AnneeEnCours = 1899 Then
MoisEnCours = 1
AnneeEnCours = 1900
MsgBox "Première année : 1900"
End If
End If
Case "MoisSuiv"
MoisEnCours = MoisEnCours + 1
If MoisEnCours = 13 Then
MoisEnCours = 1
AnneeEnCours = AnneeEnCours + 1
End If
Case "AnneeSuiv"
AnneeEnCours = AnneeEnCours + 1
End Select
CreationBoutonsJours MoisEnCours, AnneeEnCours
End Sub
Sur un autre module de classe :
Option Explicit
Public WithEvents Btn As MSForms.CommandButton
'Procédure lors du clic sur un bouton "jour"
Private Sub Btn_Click()
Dim maDate As Date
maDate = CDate(Btn.Caption & "/" & calendrier.Tag)
'La ligne suivante détermine l'action à effectuer lors d'un clic sur le bouton
'Pour entrer la date choisie dans une cellule et fermer l'Userform :
'ActiveCell.Value = maDate
'Unload Calendrier
MsgBox maDate
End Sub
'Affiche le nom du jour férié au survol du bouton par la souris
Private Sub Btn_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim maDate As Date
maDate = CDate(Btn.Caption & "/" & calendrier.Tag)
If EstJourFerie(maDate) Or Paques(Year(maDate)) = maDate Then Btn.ControlTipText = QuelFerie(maDate)
End Sub
Parce qu'en fait, le but était de l'intégrer à ma macro comme une InputBox. Il aurait fallut que je puisse faire choisir la date sur ce caldendrier et qu'elle soit stockée dans une variable qui servira à l'enregistrement du fichier et bien d'autres choses...
Que je puisse l'utiliser un peu comme ça en fait :
Public DATE_ECHEANCE As String
Sub TRAITEMENT_VIREMENTS()
If Range("A1").Font.Bold = True Then
MsgBox ("La mise en forme a déjà été faite.")
Exit Sub
End If
Dim DL As Long, DL2 As Long, DL3 As Long, Obj As Object, Code As String
Do
DATE_ECHEANCE = InputBox("Entrer la date d'échéance des factures concernées au format jj/mm/aaaa.", "Date d'échéance")
Loop While DATE_ECHEANCE = "" Or Not IsDate(DATE_ECHEANCE) Or DATE_ECHEANCE <> Format(DATE_ECHEANCE, "dd/mm/yyyy")
.
.
.
Merci beaucoup pour avoir mis le doigt sur cette erreur des plus stupides...
Savez-vous à quel endroit du code il est dit que si je clique sur un jour dans le calendrier une MsgBox apparaît en me donnant la date sur laquelle j'ai cliqué?
Au lieu d'une MsgBox, je voudrais bien stocker cette réponse dans une variable en fait. Que je puisse m'en resservir. Comme une InputBox quoi.
Et comment faire pour qu'une fois que j'ai choisi ma date et que la variable est stockée, le calendrier se ferme?
Option Explicit
Public WithEvents Btn As MSForms.CommandButton
'Procédure lors du clic sur un bouton "jour"
Private Sub Btn_Click()
Dim maDate As Date
maDate = CDate(Btn.Caption & "/" & calendrier.Tag)
'La ligne suivante détermine l'action à effectuer lors d'un clic sur le bouton
'Pour entrer la date choisie dans une cellule et fermer l'Userform :
'ActiveCell.Value = maDate
DATE_ECHEANCE = maDate
Unload Calendrier
End Sub
Dernière petite question, là j'ai un calendrier qui arrive parfait. Serait-il possible d'écrire dessus un titre du genre : "Choisissez la date d'échéance"?
Là j'ai l'impression que tous les espaces sont utilisés..
J'ai un petit soucis par contre, j'ai donc modifié le code en :
Option Explicit
Public DATE_ECHEANCE As String
Public WithEvents Btn As MSForms.CommandButton
'Procédure lors du clic sur un bouton "jour"
Private Sub Btn_Click()
Dim maDate As Date
DATE_ECHEANCE = CDate(Btn.Caption & "/" & Calendrier.Tag)
'La ligne suivante détermine l'action à effectuer lors d'un clic sur le bouton
'Pour entrer la date choisie dans une cellule et fermer l'Userform :
'ActiveCell.Value = maDate
Unload Calendrier
End Sub
Mon code final est donc :
Sub TRAITEMENT_FINAL()
Calendrier.Show
Call TRAITEMENT_VIREMENTS
End Sub
Qui appelle le code suivant :
Sub TRAITEMENT_VIREMENTS()
If Range("A1").Font.Bold = True Then
MsgBox ("La mise en forme a déjà été faite.")
Exit Sub
End If
Dim DL As Long, DL2 As Long, DL3 As Long, Obj As Object, Code As String
Range("A:E,I:O,Q:Q,S:S").Delete
Rows(4).Delete
DL = Cells(Application.Rows.Count, 4).End(xlUp).Row
For i = DL To 4 Step -1
If Range("A" & i) = "" Then
Range("A" & i).Value = CDate(Range("A" & i - 1).Value)
Range("B" & i).Value = Range("B" & i - 1).Value
Range("C" & i).Value = Range("C" & i - 1).Value
Range("E" & i).Value = Range("E" & i - 1).Value
Range("F" & i).Value = Range("F" & i - 1).Value
Range("G" & i).Value = Range("G" & i - 1).Value
Range("H" & i).Value = CDate(Range("H" & i - 1).Value)
Rows(i - 1).Delete
i = i - 1
ElseIf Range("B" & i) = Range("B" & i + 1) And Range("C" & i) = Range("C" & i + 1) Then
Rows(i).Delete
End If
Next i
Range("F:F").HorizontalAlignment = xlLeft
DL3 = Cells(Application.Rows.Count, 1).End(xlUp).Row
Range("B4").Copy
Range(Cells(4, 4), Cells(DL3, 4)).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
With Range("D4:D" & DL3)
.NumberFormat = "0.00"
.Font.Size = 16
.Font.Bold = True
.Font.Color = RGB(255, 0, 0)
End With
With Range("B4:B" & DL3)
.Font.Size = 16
.Font.Bold = True
End With
With Range("F4:F" & DL3)
.Font.Size = 16
.Font.Bold = True
End With
With Range("H4:H" & DL3)
.Font.Size = 16
.Font.Bold = True
End With
With Range("A2:H3")
.HorizontalAlignment = xlCenter
.Font.Bold = True
.Font.Size = 11
End With
DL2 = Cells(Application.Rows.Count, 1).End(xlUp).Row
For T = 4 To DL2
Rows(T).RowHeight = 22.5
Next T
Range("A:J").ColumnWidth = 14
Range("A:H").ColumnWidth = 16
Range("F:F").ColumnWidth = 23
Range("B:B").ColumnWidth = 20
Range("E:E").ColumnWidth = 7
Range("G:G").ColumnWidth = 11
Range("I:I").ColumnWidth = 28
Range("J:J").ColumnWidth = 9
Rows(1).RowHeight = 28
With Range("A1:J1")
.Merge
.Font.Bold = True
.Font.Size = 20
.HorizontalAlignment = xlCenter
End With
Range("A1").Value = "VIREMENTS ECHEANCE " & Replace(DATE_ECHEANCE, "/", ".")
Rows(3).RowHeight = 20
Range("I2:I3").Merge
Range("J2:J3").Merge
Range("G2").Copy
Range(Cells(2, 9), Cells(2, 10)).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("I2").Value = "Commentaires"
Range("J2").Value = "Valid."
With Range("A1:J1").Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
Range("A2").Select
End Sub
Ne fonctionne-t-elle pas. en fait la valeur de A1 est "VIREMENTS ECHEANCE" et j'ai rien après. Comme si le code n'avait pas tenu compte de mon Userform...
Savez-vous à quel endroit du code il est dit que si je clique sur un jour dans le calendrier une MsgBox apparaît en me donnant la date sur laquelle j'ai cliqué?
Au lieu d'une MsgBox, je voudrais bien stocker cette réponse dans une variable en fait. Que je puisse m'en resservir. Comme une InputBox quoi.
Et comment faire pour qu'une fois que j'ai choisi ma date et que la variable est stockée, le calendrier se ferme?
Merci encore.
Merci beaucoup.
Là j'ai l'impression que tous les espaces sont utilisés..
Mon code final est donc :
Qui appelle le code suivant :
Pourquoi la partie :
Ne fonctionne-t-elle pas. en fait la valeur de A1 est "VIREMENTS ECHEANCE" et j'ai rien après. Comme si le code n'avait pas tenu compte de mon Userform...
Merci.