XL 2016 Instruction Cdate fait planter mon code

MONADESIGN82 · 18 Février 2022

Bonjour à tous,
Le code joint me sert pour incrémenter des dates dans différentes cellules de mon fichier.
Une fois saisies dans le UF puis validées, la mise à jour se fait et les dates vont bien dans leurs cellules respectives.

VB:

Dim Ws As Worksheet
 
'RAZ
Private Sub CommandButton4_Click()
ComboBox1.Value = ""
TextBox1.Value = ""
TextBox2.Value = ""
TextBox3.Value = ""
TextBox4.Value = ""
TextBox5.Value = ""
TextBox6.Value = ""
TextBox7.Value = ""
TextBox8.Value = ""
TextBox9.Value = ""
TextBox10.Value = ""
TextBox11.Value = ""
TextBox12.Value = ""
TextBox13.Value = ""
TextBox14.Value = ""
TextBox15.Value = ""
TextBox16.Value = ""
TextBox17.Value = ""
TextBox18.Value = ""
 
UserForm1.ComboBox1.SetFocus
 
Dim Ctl As Control
 
For Each Ctl In Me.Controls
 
If Ctl.Tag = "LblZoneA" Then
Ctl = ""
 
End If
 
Next Ctl
 
End Sub
 
 
'Ouvrir le PDF du BC'
Private Sub CommandButton9_Click()
Dim Cible As String, LeBC As String
Dim OuvrirFichier As Object
 
    If Me.ComboBox1.ListIndex = -1 Or Me.ComboBox1 = "" Then Exit Sub
    LeBC = Me.ComboBox1
    Cible = "\Commun\2. PR_BCR\Contrat\2-BC\BC Notifiés\" & "BC " & LeBC & ".pdf"
    Set OuvrirFichier = CreateObject("Scripting.FileSystemObject")
    With OuvrirFichier
        If (.FileExists(Cible)) Then
            Shell "C:\WINDOWS\explorer.exe """ & Cible & "", vbNormalFocus
        Else
            MsgBox "Impossible d'atteindre le fichier (""" & Cible & """)" & Chr(10) & Chr(10) & "Il a pu être déplacé, renommé ou supprimé.", vbCritical
        End If
    End With
End Sub
 
'Ouvrir la DR'
Private Sub CommandButton13_Click()
Dim Cible As String, LaDR As String, LeBC As String
Dim OuvrirFichier As Object
 
    If Me.ComboBox1.ListIndex = -1 Or Me.ComboBox1 = "" Then Exit Sub
    LaDR = Me.Label71.Caption
    LeBC = Me.ComboBox1
    Cible = "Commun\2. PR_BCR\Contrat\3-DR DLR DAJ Décisions notifiées\" & "DR" & LaDR & " BC" & LeBC & ".zip"
    Set OuvrirFichier = CreateObject("Shell.Application")
    If Len(Dir(Cible)) > 0 Then
        OuvrirFichier.Open (Cible)
    End If
 
    If Me.ComboBox1.ListIndex = -1 Or Me.ComboBox1 = "" Then Exit Sub
    LaDR = Me.Label71.Caption
    LeBC = Me.ComboBox1
    Cible = "Commun\2. PR_BCR\Contrat\3-DR DLR DAJ Décisions notifiées\" & "DR" & LaDR & " BC" & LeBC & ".pdf"
    Set OuvrirFichier = CreateObject("Shell.Application")
    If Len(Dir(Cible)) > 0 Then
        OuvrirFichier.Open (Cible)
    End If
 
    If Me.ComboBox1.ListIndex = -1 Or Me.ComboBox1 = "" Then Exit Sub
    LaDR = Me.Label71.Caption
    LeBC = Me.ComboBox1
    Cible = "Commun\2. PR_BCR\Contrat\3-DR DLR DAJ Décisions notifiées\" & "DR" & LaDR & " DLR" & " BC" & LeBC & ".zip"
    Set OuvrirFichier = CreateObject("Shell.Application")
    If Len(Dir(Cible)) > 0 Then
        OuvrirFichier.Open (Cible)
    End If
 
    If Me.ComboBox1.ListIndex = -1 Or Me.ComboBox1 = "" Then Exit Sub
    LaDR = Me.Label71.Caption
    LeBC = Me.ComboBox1
    Cible = "Commun\2. PR_BCR\Contrat\3-DR DLR DAJ Décisions notifiées\" & "DR" & LaDR & " DLR" & " BC" & LeBC & ".pdf"
    Set OuvrirFichier = CreateObject("Shell.Application")
    If Len(Dir(Cible)) > 0 Then
        OuvrirFichier.Open (Cible)
    End If
 
    If Me.ComboBox1.ListIndex = -1 Or Me.ComboBox1 = "" Then Exit Sub
    LaDR = Me.Label71.Caption
    LeBC = Me.ComboBox1
    Cible = "Commun\2. PR_BCR\Contrat\3-DR DLR DAJ Décisions notifiées\" & "DR" & LaDR & " DAJ" & " BC" & LeBC & ".zip"
    Set OuvrirFichier = CreateObject("Shell.Application")
    If Len(Dir(Cible)) > 0 Then
        OuvrirFichier.Open (Cible)
    End If
 
    If Me.ComboBox1.ListIndex = -1 Or Me.ComboBox1 = "" Then Exit Sub
    LaDR = Me.Label71.Caption
    LeBC = Me.ComboBox1
    Cible = "Commun\2. PR_BCR\Contrat\3-DR DLR DAJ Décisions notifiées\" & "DR" & LaDR & " DAJ" & " BC" & LeBC & ".pdf"
    Set OuvrirFichier = CreateObject("Shell.Application")
    If Len(Dir(Cible)) > 0 Then
        OuvrirFichier.Open (Cible)
    End If
 
    If Me.ComboBox1.ListIndex = -1 Or Me.ComboBox1 = "" Then Exit Sub
    LaDR = Me.Label71.Caption
    LeBC = Me.ComboBox1
    Cible = "Commun\2. PR_BCR\Contrat\3-DR DLR DAJ Décisions notifiées\" & "DR" & LaDR & " DRP" & " BC" & LeBC & ".zip"
    Set OuvrirFichier = CreateObject("Shell.Application")
    If Len(Dir(Cible)) > 0 Then
        OuvrirFichier.Open (Cible)
    End If
 
    If Me.ComboBox1.ListIndex = -1 Or Me.ComboBox1 = "" Then Exit Sub
    LaDR = Me.Label71.Caption
    LeBC = Me.ComboBox1
    Cible = "Commun\2. PR_BCR\Contrat\3-DR DLR DAJ Décisions notifiées\" & "DR" & LaDR & " DRP" & " BC" & LeBC & ".pdf"
    Set OuvrirFichier = CreateObject("Shell.Application")
    If Len(Dir(Cible)) > 0 Then
        OuvrirFichier.Open (Cible)
    End If
 
End Sub
 
 
'Ouvrir un dossier'
Private Sub CommandButton10_Click()
Dim Cible As String, NomDossier As String
Dim OuvrirDossier As Object
Dim FichierExiste As Boolean
Dim TailleDossier As Integer
Dim LimiteInf As Long, LimiteSup As Long, i As Long, LeBC As Long
 
    If Me.ComboBox1.ListIndex = -1 Or Me.ComboBox1 = "" Then Exit Sub
    LeBC = CLng(Me.ComboBox1)
    TailleDossier = 50
    For i = 1 To 1500 Step TailleDossier
        LimiteInf = i
        LimiteSup = i + TailleDossier - 1
        If LeBC >= LimiteInf And LeBC <= LimiteSup Then NomDossier = "BC " & LimiteInf & "à" & LimiteSup: Exit For
    Next i
    Cible = "Commun\2. PR_BCR\Contrat\2-BC\" & NomDossier
    Set OuvrirDossier = CreateObject("Scripting.FileSystemObject")
    With OuvrirDossier
        If (.FolderExists(Cible)) Then
            Shell "C:\WINDOWS\explorer.exe """ & Cible & "", vbNormalFocus
            'Ou : Shell "C:\WINDOWS\explorer.exe " & cible, vbNormalFocus
        Else
            MsgBox "Le dossier n'existe pas, il a peut-être été supprimé ou déplacé.", vbExclamation
        End If
    End With
End Sub
 
'Pour le formulaire
Private Sub UserForm_Initialize()
Application.ScreenUpdating = False
Dim J As Long, i%, L%
With Worksheets("BC")
    L = .Range("ED" & Rows.Count).End(xlUp).Row
    For J = 10 To L
        Me.ComboBox1.AddItem .Range("ED" & J)
    Next J
 
    Me.Label71 = .Range("ED65000").End(xlUp).Rows
End With
Application.ScreenUpdating = True
End Sub
 
'Pour la liste déroulante BC
Private Sub ComboBox1_Change()
Application.ScreenUpdating = False
Dim i%, L%
With Worksheets("BC")
On Error GoTo SORTIE
    L = Application.Match(Me.ComboBox1, .Range("ED10:ED" & .Cells(.Rows.Count, 134).End(xlUp).Row), 0) + 9
    If Me.ComboBox1.ListIndex = -1 Then Exit Sub
    For i = 1 To 18
        Me.Controls("TextBox" & i) = .Cells(L, i + 144)
    Next i
    Me.Label46 = CStr(Application.Index(.Range("FG:FG"), L))
    Me.Label47 = CStr(Application.Index(.Range("FH:FH"), L))
    Me.Label52 = CStr(Application.Index(.Range("BZ:BZ"), L))
    Me.Label54 = CStr(Application.Index(.Range("I:I"), L))
    Me.Label56 = CStr(Application.Index(.Range("FI:FI"), L))
    Me.Label61 = CStr(Application.Index(.Range("AA:AA"), L))
    Me.Label59 = CStr(Application.Index(.Range("AH:AH"), L))
    Me.Label63 = CStr(Application.Index(.Range("FJ:FJ"), L))
    Me.Label64 = CStr(Application.Index(.Range("AI:AI"), L))
    Me.Label66 = CStr(Application.Index(.Range("J:J"), L))
    Me.Label67 = CStr(Application.Index(.Range("K:K"), L))
    Me.Label69 = CStr(Application.Index(.Range("AL:AL"), L))
    Me.Label71 = CStr(Application.Index(.Range("AO:AO"), L))
    Me.Label73 = CStr(Application.Index(.Range("AN:AN"), L))
    Me.Label74 = CStr(Application.Index(.Range("L:L"), L))
    Me.Label77 = CStr(Application.Index(.Range("HA:HA"), L))
    Me.Label78 = CStr(Application.Index(.Range("HB:HB"), L))
    Me.Label85 = CStr(Application.Index(.Range("AR:AR"), L))
    Me.Label86 = CStr(Application.Index(.Range("AS:AS"), L))
    Me.Label87 = CStr(Application.Index(.Range("AT:AT"), L))
    Me.Label88 = CStr(Application.Index(.Range("AU:AU"), L))
    Me.Label90 = CStr(Application.Index(.Range("Z:Z"), L))
 
Me.Label85.Caption = Format(Round(CDbl(Application.Index(.Range("AR:AR"), L)), 2), "###,##0.00")
Me.Label86.Caption = Format(Round(CDbl(Application.Index(.Range("AS:AS"), L)), 2), "###,##0.00")
Me.Label87.Caption = Format(Round(CDbl(Application.Index(.Range("AT:AT"), L)), 2), "###,##0.00")
Me.Label88.Caption = Format(Round(CDbl(Application.Index(.Range("AU:AU"), L)), 2), "###,##0.00")
 
End With
Exit Sub
Application.ScreenUpdating = True
SORTIE:  MsgBox "BC non trouvé, merci de recommencer une nouvelle saisie", vbCritical: Exit Sub
End Sub
 
'Pour le suivi des visas'
 
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim L As Integer
 
 
     Range("ED" & L).Value = ComboBox1
     Range("EO" & L).Value = CDate(Me.TextBox1)
     Range("EP" & L).Value = CDate(Me.TextBox2)
     Range("EQ" & L).Value = CDate(Me.TextBox3)
     Range("ER" & L).Value = CDate(Me.TextBox4)
     Range("ES" & L).Value = CDate(Me.TextBox5)
     Range("ET" & L).Value = CDate(Me.TextBox6)
     Range("EU" & L).Value = CDate(Me.TextBox7)
     Range("EV" & L).Value = CDate(Me.TextBox8)
     Range("EW" & L).Value = CDate(Me.TextBox9)
     Range("EX" & L).Value = CDate(Me.TextBox10)
     Range("EY" & L).Value = CDate(Me.TextBox11)
     Range("EZ" & L).Value = CDate(Me.TextBox12)
     Range("FA" & L).Value = CDate(Me.TextBox13)
     Range("FB" & L).Value = CDate(Me.TextBox14)
     Range("FC" & L).Value = CDate(Me.TextBox15)
     Range("FD" & L).Value = CDate(Me.TextBox16)
     Range("FE" & L).Value = CDate(Me.TextBox17)
     Range("FF" & L).Value = CDate(Me.TextBox18)
 
 End If
Application.ScreenUpdating = True
End Sub
 
'Pour le bouton Modifier
Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
Dim i%, L%
With Worksheets("BC")
   If MsgBox("Confirmez-vous les modifications apportées ?", vbYesNo, "Demande de confirmation de modification") = vbYes Then
        If Me.ComboBox1.ListIndex = -1 Then Exit Sub
        On Error GoTo SORTIE
        L = Application.Match(Me.ComboBox1, .Range("ED10:ED" & .Cells(.Rows.Count, 134).End(xlUp).Row), 0) + 9
 
            For i = 1 To 18
            If Me.Controls("TextBox" & i).Visible = True Then
                .Cells(L, i + 144) = CDate(Me.Controls("TextBox" & i))
            End If
        Next i
    Me.Label46 = CStr(Application.Index(.Range("FG:FG"), L))
    Me.Label47 = CStr(Application.Index(.Range("FH:FH"), L))
    Me.Label52 = CStr(Application.Index(.Range("BZ:BZ"), L))
    Me.Label54 = CStr(Application.Index(.Range("I:I"), L))
    Me.Label56 = CStr(Application.Index(.Range("FI:FI"), L))
    Me.Label61 = CStr(Application.Index(.Range("AA:AA"), L))
    Me.Label59 = CStr(Application.Index(.Range("AH:AH"), L))
    Me.Label63 = CStr(Application.Index(.Range("FJ:FJ"), L))
    Me.Label64 = CStr(Application.Index(.Range("AI:AI"), L))
    Me.Label66 = CStr(Application.Index(.Range("J:J"), L))
    Me.Label67 = CStr(Application.Index(.Range("K:K"), L))
    Me.Label69 = CStr(Application.Index(.Range("AL:AL"), L))
    Me.Label71 = CStr(Application.Index(.Range("AO:AO"), L))
    Me.Label73 = CStr(Application.Index(.Range("AN:AN"), L))
    Me.Label74 = CStr(Application.Index(.Range("L:L"), L))
    Me.Label77 = CStr(Application.Index(.Range("HA:HA"), L))
    Me.Label78 = CStr(Application.Index(.Range("HB:HB"), L))
    Me.Label85 = CStr(Application.Index(.Range("AR:AR"), L))
    Me.Label86 = CStr(Application.Index(.Range("AS:AS"), L))
    Me.Label87 = CStr(Application.Index(.Range("AT:AT"), L))
    Me.Label88 = CStr(Application.Index(.Range("AU:AU"), L))
    Me.Label90 = CStr(Application.Index(.Range("Z:Z"), L))
 
Me.Label85.Caption = Format(Round(CDbl(Application.Index(.Range("AR:AR"), L)), 2), "###,##0.00")
Me.Label86.Caption = Format(Round(CDbl(Application.Index(.Range("AS:AS"), L)), 2), "###,##0.00")
Me.Label87.Caption = Format(Round(CDbl(Application.Index(.Range("AT:AT"), L)), 2), "###,##0.00")
Me.Label88.Caption = Format(Round(CDbl(Application.Index(.Range("AU:AU"), L)), 2), "###,##0.00")
 
 
            End If
    Me.Label71 = .Range("ED65000").End(xlUp).Rows
 
End With
Exit Sub
SORTIE:  MsgBox "BC non trouvé, merci de recommencer une nouvelle saisie", vbCritical: Exit Sub
Application.ScreenUpdating = True
Me.Repaint
End Sub
 
'Ouvrir le dossier des DR notifiés'
Private Sub CommandButton5_Click()
Application.ScreenUpdating = False
Dim MonDossier As String
MonDossier = "Commun\2. PR_BCR\Contrat\3-DR DLR DAJ Décisions notifiées"
Shell Environ("WINDIR") & "\explorer.exe " & MonDossier, vbMaximizedFocus
Application.ScreenUpdating = True
End Sub
 
'Ouvrir le dossier des BC notifiés'
Private Sub CommandButton7_Click()
Application.ScreenUpdating = False
Dim MonDossier As String
MonDossier = "Commun\2. PR_BCR\Contrat\2-BC"
Shell Environ("WINDIR") & "\explorer.exe " & MonDossier, vbMaximizedFocus
Application.ScreenUpdating = True
End Sub
 
'Ouvrir le dossier des visas'
Private Sub CommandButton11_Click()
Application.ScreenUpdating = False
Dim MonDossier As String
MonDossier = "S:\DIR\Transverse\Actes_a_signer"
Shell Environ("WINDIR") & "\explorer.exe " & MonDossier, vbMaximizedFocus
Application.ScreenUpdating = True
End Sub
 
'Pour le bouton Quitter
 
Private Sub CommandButton3_Click()
 
   Unload Me
 
End Sub

Problème:

Les dates ne sont pas REELLEMENT incrémentées au format "DATE"
--> En effet, Lorsque je fais un filtre sur une colonne, les dates ne sont pas reconnues en tant que date mais en tant que texte.

J'ai essayé en ajoutant "Cdate" (qui fonctionne pour le coup, une fois que je valide les dates sont bien envoyées au format DATE)

Code:

            For i = 1 To 18
            If Me.Controls("TextBox" & i).Visible = True Then
                .Cells(L, i + 144) = CDate(Me.Controls("TextBox" & i))
            End If

MAIS, cela fait planter la Macro. (photo jointe)

Question subsidaire :

J'ai téléchargé le module de classe pour avoir directement des DateBox à la place des TextBox (Fichier joint)
Comment dois-je adapter le code pour qu'il soit fonctionnel

Merci par avance pour votre aide

Staple1600 · 19 Février 2022

Bonjour,

Sur ce petit test simple
(1 userform avec un TextBox et un CommandButton)

VB:

Private Sub CommandButton1_Click()
vDate = CDate(TextBox1.Text)
[A1] = vDate
[A1:A10].DataSeries , 1
End Sub

Saisie d'une date manuellement dans le TextBox1 (avec ce format de saisie) : jj/mm/aaaa
Puis click sur le CommandButton
C'est bien de "vraies dates" qui sont renvoyées sur la feuille.
(en tout cas, c'est le cas sur mon PC)

Donc à vue de nez, c'est la manière de remplir les TextBox qui semble poser problème avec ton fichier, non ?

EDITION: je rajoute un peu de code pour tester plusieurs fois de suite

VB:

Private Sub CommandButton1_Click()
vDate = CDate(TextBox1)
[A1] = vDate
[A1:A10].DataSeries , 1
Unload UserForm1
End Sub

Private Sub UserForm_Initialize()
Randomize
TextBox1 = Date + Application.RandBetween(1, 28)
End Sub

Et dans un module standard

VB:

Sub Show()
UserForm1.Show
End Sub

(que l'on associe à un bouton par exemple)

Au final, j'ai toujours des dates dans la plage A1:A10

dysorthographie · 19 Février 2022

Bonsoir,

Code:

[A1] = Format(TextBox1,"yyyy-mm-dd")

MONADESIGN82 · 21 Février 2022

Bonjour à vous deux !
Je n'ai pas réussi à adapter ton code au mien.
En revanche j'ai fait ceci :

VB:

            For i = 1 To 18
                If Me.Controls("DateBox" & i).Visible = True Then
                    If IsDate(Me.Controls("DateBox" & i)) Then
                    .Cells(L, i + 144) = CDate(Me.Controls("DateBox" & i).Value)
                    End If
                End If
        Next i

Cela fonctionne, mais ! (Eh oui encore en mais

Une fois les dates validées et incrémentées dans les cellules correspondantes, admettons que je fasse une erreur et souhaite (modifier / effacer) la date, puis que je clique à nouveau sur le bouton modifier, plus rien ne se passe (alors que sans cet ajout cela fonctionne)

XL 2016 Instruction Cdate fait planter mon code

MONADESIGN82

XLDnaute Nouveau

Pièces jointes

Staple1600

XLDnaute Barbatruc

dysorthographie

XLDnaute Accro

MONADESIGN82

XLDnaute Nouveau

Discussions similaires