XL 2016 Instruction Cdate fait planter mon code

M

MONADESIGN82

XLDnaute Nouveau
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)
photo 4.jpg


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 :)
 

Pièces jointes

  • numbox-et-datebox.xlsm
    30.2 KB · Affichages: 11
Trier par date Trier par votes
Staple1600

Staple1600

XLDnaute Barbatruc
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
 
Dernière édition:
Vote positif 0 Vote négatif
M

MONADESIGN82

XLDnaute Nouveau
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)
 
Vote positif 0 Vote négatif

Discussions similaires

lynyrd
  • Question
XL 2019 code pour tous les disques
Réponses
3
Affichages
528
AtTheOne
AtTheOne
I
  • Question
XL 2016 Modification d'une ligne dans mon code
Réponses
2
Affichages
577
INFINITY100
I
GADENSEB
  • Question
Microsoft 365 Macro .XLA découpage de fichiers à passer en X64
Réponses
8
Affichages
666
GADENSEB
GADENSEB
J
  • Question
XL 2016 [RESOLU] Avis Code VBA excel
Réponses
9
Affichages
922
jabenj
J
I
  • Question
XL 2016 Mon code VBA me renvoi une erreur
Réponses
6
Affichages
685
INFINITY100
I
J
  • Question
XL 2019 probleme Sheets("entreeor").ListObjects(1).ListRows.Add
Réponses
11
Affichages
1 K
Gégé-45550
Gégé-45550
T
  • Question
XL 2016 Modification de données sur 2 feuilles différentes via UserForm
Réponses
14
Affichages
2 K
tontonboulii
T
R
  • Question
XL 2019 Fichier inscription VBA
Réponses
0
Affichages
910
Richard 58
R
M
  • Question
XL 2019 VBA Remplacer des cellule par valeur tableau et Aide Userform
Réponses
1
Affichages
854
fanch55
fanch55
G
  • Question
XL 2016 Ecrire une boucle pour afficher ensemble dans un userform, toutes ses textbox complétées par la boucle! Voir mon code et photos feuilles joints !
Réponses
8
Affichages
901
vgendron
vgendron

Membres actuellement en ligne

12 membres et 103 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 091
Messages
2 116 109
Membres
112 662
dernier inscrit
lou75