VBA : Date Serial via autre fichier

Bonjour à tous,

J'ai déjà ouvert un sujet mais celui ci ayant été partiellement résolu, j'en ouvre un spécialement à ce problème :

Je souhaite conditionner l'ouverture d'un fichier si celui ci dépasse une certaine date (le fichier ne s'ouvre pas si la date est dépassée)

Le fichier excel qui s'ouvre , et qui doit s'interroger si la date d'expiration est toujours bonne, devrait aller chercher cette information dans un autre fichier excel.

Voici le code utilisé et fonctionnel mais uniquement si c'est dans le fichier

Private Sub Workbook_Open()
Dim iYear As Integer
Dim iMonth As Integer
Dim iDay As Integer
Dim dDate As Date

iYear = Sheets("Feuil1").Range("A1")
iMonth = Sheets("Feuil1").Range("A2")
iDay = Sheets("Feuil1").Range("A3")

dDate = DateSerial(iYear, iMonth, iDay)

Application.ScreenUpdating = False

If dDate <= Date Then
    Application.DisplayAlerts = False
    ThisWorkbook.Close SaveChanges:=False
    Application.DisplayAlerts = True
Else
End If
Application.ScreenUpdating = True
End Sub

Donc en A1 j'ai l'année, A2 le mois et A3 le jour.

J'ai des connaissances limitées en VBA mais j'ai testé le code suivant :

Private Sub Workbook_Open()
Dim iYear As Integer
Dim iMonth As Integer
Dim iDay As Integer
Dim dDate As Date
Dim Depart As String

Depart = "C:\Mes Documents\Date.xlsx"

iYear = Depart & Sheets("Feuil1").Range("A1")
iMonth = Depart & Sheets("Feuil1").Range("A2")
iDay = Depart & Sheets("Feuil1").Range("A3")

dDate = DateSerial(iYear, iMonth, iDay)

Application.ScreenUpdating = False

If dDate <= Date Then
    Application.DisplayAlerts = False
    ThisWorkbook.Close SaveChanges:=False
    Application.DisplayAlerts = True
Else
End If
Application.ScreenUpdating = True
End Sub

Donc dans ce code j'ai simplement ajouter Depart as String + Depart = Chemin du fichier qui contient la date (c:/mes doc..) + Depart & Sheets("feuil1") etc...

J'ai toujours une erreur 13 "incompatibilité de type"

Est-ce que quelqu'un a une solution ?

Merci par avance

Cordialement

bonjour,

si tu nous mettais ton code avec tes ajouts ?

Bonjour h2so4,

Le code avec mes ajouts est en deuxième partie (là où j'ai rajouté Depart as String , etc) . C'est cette partie qui me renvoi une erreur 13.

Tu voulais peut être un fichier ? (mais il ne sert à rien en l'état... à part pour vous montrer le code original, qui fonctionne)

Cdt

rebonjour,

désolé je n'ai pas les yeux en face des trous. Toute l'info nécessaire était bien dans ton message initial

Private Sub Workbook_Open()
    Dim iYear As Integer
    Dim iMonth As Integer
    Dim iDay As Integer
    Dim dDate As Date
    Dim Depart

    Set Depart = Workbooks.Open("C:\Mes Documents\Date.xlsx")

    iYear = Depart.Sheets("Feuil1").Range("A1")
    iMonth = Depart.Sheets("Feuil1").Range("A2")
    iDay = Depart.Sheets("Feuil1").Range("A3")
    Depart.Close False
    dDate = DateSerial(iYear, iMonth, iDay)

    Application.ScreenUpdating = False

    If dDate <= Date Then
        Application.DisplayAlerts = False
        ThisWorkbook.Close SaveChanges:=False
        Application.DisplayAlerts = True
    Else
    End If
    Application.ScreenUpdating = True
End Sub

Rebonjour,

D'accord je transmets un fichier ce sera plus simple peut être ^^ mais ça nécessite la création d'un autre fichier

Rebonjour,

j'avais adapté ma réponse entre temps. A nouveau, désolé de n'avoir pas lu correctement ton premier message et de t'avoir demandé de répéter ce que tu as avais déjà dit.

Pas de soucis !

Ton code fonctionne parfaitement, merci beaucoup !

Sujet résolu.

Bonjour,

Désolé d'ouvrir à nouveau le sujet, j'ai besoin d'une légère amélioration.

Est-il possible de ne pas afficher de message d'erreur, si par exemple le fichier "Depart" est introuvable ?

J'ai ajouté Application.DisplayAlerts = False avant le Set Depart :

 ... 
    Application.DisplayAlerts = False

    Set Depart = Workbooks.Open("C:\Mes Documents\Date.xlsx")

    ...

Ca n'affiche plus le message de type "Le fichier est introuvable.. etc etc..." , par contre ça met quand même "Erreur d'exécution '1004', excel ne peut accéder au fichier ...

En gros je souhaite que le fichier soit tout de même accessible, j'aimerais juste aucun message d'erreur.

Merci par avance.

Cdt

Edit : je viens de trouver. Si ça interesse quelqu'un, il faut modifier le code comme ça :

 ... 
    Application.DisplayAlerts = False
    On Error Resume Next
    Set Depart = Workbooks.Open("C:\Mes Documents\Date.xlsx")
    ...

 ... 
    Application.DisplayAlerts = False
    On Error GoTo fin
    Set Depart = Workbooks.Open("C:\Mes Documents\Date.xlsx")
    ...
...
...
fin:
End Sub

bonjour,

voici une adaptation du code

Private Sub Workbook_Open()
    Dim iYear As Integer
    Dim iMonth As Integer
    Dim iDay As Integer
    Dim dDate As Date
    Dim Depart As Workbook
    Dim sFichier As String

    sFichier = "C:\Mes Documents\Date.xlsx"

    If Dir(fichier) <> "" Then 'fichier existe

        Set Depart = Workbooks.Open(sFichier)

        iYear = Depart.Sheets("Feuil1").Range("A1")
        iMonth = Depart.Sheets("Feuil1").Range("A2")
        iDay = Depart.Sheets("Feuil1").Range("A3")
        Depart.Close False
        dDate = DateSerial(iYear, iMonth, iDay)

        Application.ScreenUpdating = False
        If dDate <= Date Then
            Application.DisplayAlerts = False
            ThisWorkbook.Close SaveChanges:=False
            Application.DisplayAlerts = True
        Else
        End If
        Application.ScreenUpdating = True

    End If
End Sub

Merci pour la réponse h2so4

Je vais tester ton code,

J'ai édité mon message initial, peux tu y jeter un oeil ?