Fonction "workbook.open" ne fonctionne pas...

[nikkss]

Bonjour le forum,

J'ai un soucis bizarre. Je développe une macro qui doit aller copier des lignes dans tous les fichiers contenus dans un répertoire vers mon fichier qui abrite la macro. Je boucle donc sur tous les fichiers avec la fonction "Dir", puis j'essaie d'ouvrir chaque fichier pour en extraire les lignes voulues, et là ça ne fonctionne pas. Arrivé à la ligne avec le "Open", le code s'arrête carrément sans même ouvrir le fichier. Le pas à pas arrête l'éxécution après être passé sur cette ligne.
Le code:

Option Explicit
'
Public wbStat As Workbook
Public wbRapport As Workbook
Public Chemin As String
Public Fichier As String
Public NbFichierXLSX As Integer

Public Sub Main()
Dim derligRapport, derligStat As Integer
Dim cellule, cell, DateRapport, maColonneDate As Variant
Dim Message, monColonneHeureDeb As Variant

Set wbStat = ActiveWorkbook
derligStat = wbStat.Sheets(1).Range("B" & Rows.Count).End(xlUp).Row
Set maColonneDate = wbStat.Sheets(1).Range("A2:A" & derligStat)

'On masque l'execution de la macro à l'écran
On Error GoTo FinMacro
Application.ScreenUpdating = False

'Définit le répertoire contenant les fichiers
'Message = MsgBox("Vous devez sélectionner le dossier contenant les fichiers excel servant au calcul de statistiques", vbOKOnly, "Choix du dossier des rapports BORD")
Call SelDossier("Y:\")
'Compte le nombre de rapports présents dans le dossier sélectionné
Call NbFichier("Y:\toto\tata", "xlsx")

'Boucle sur tous les rapports du répertoire "Chemin" spécifié au dessus
Fichier = Dir("Y:\toto\tata" & "\*.xlsx")
Set wbRapport = Application.Workbooks.Open("Y:\toto\tata\" & Fichier)  'On ouvre le premier rapport du répertoire

Do While Len(Fichier) > 0
    DateRapport = wbRapport.Sheets(1).Range("B2").Value
    derligRapport = wbRapport.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
    Set monColonneHeureDeb = wbRapport.Sheets(1).Range("A5:A" & derligRapport)
    
    For Each cell In maColonneDate
        If cell = DateRapport Then
            GoTo ficSuiv
            Else: For Each cellule In monColonneHeureDeb
                    If cellule <> "Heure Début" Then
                        GoTo suivant
                    Else: cellule.Row = cellule.Row + 1
                        While cellule.Offset(1, 0) <> "Journée du:"
                            derligStat = wbStat.Sheets(1).Range("B" & Rows.Count).End(xlUp).Row
                            wbRapport.Sheets(1).Range("A" & cellule.Row & ":G" & cellule.Row).Copy wbStat.Sheets(1).Range("B" & derligStat)
                            wbStat.Sheets(1).Range("A" & derligStat).Value = DateRapport
                        Wend
                    End If
suivant:         Next
        End If
    Next
    
ficSuiv: Loop

'On rétablit le screenUpdatiing à true
Application.ScreenUpdating = True

FinMacro: End Sub

'Cette fonction permet de déterminer l'adresse d'un répertoire sélectionné par l'utilisateur
'Ici l'utilisateur doit sélectionner le répertoire où se situe les rapports BORD nécessaires au remplissage des schémas
Function SelDossier(Defaut As String)
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
    .InitialFileName = Defaut
    If .Show = -1 Then
        SelDossier = fd.SelectedItems(1)
        Chemin = SelDossier
    End If
End With
Set fd = Nothing
End Function

'Fonction de calcul du nombre de rapports BORD dans le répertoire spécifié par l'utilisateur
'Ici on compte ces fichiers pour établir l'avancement de la waitingBarre
Function NbFichier(Cheminrep As String, ParamArray Termin() As Variant) As Long
Dim FichierXLSX As String
Dim Extension As Variant
Dim Compteur As Long
 
For Each Extension In Termin
   FichierXLSX = Dir(Cheminrep & "\*." & Extension)
   Do Until FichierXLSX = ""
   Compteur = Compteur + 1
   FichierXLSX = Dir
   Loop
Next Extension
 
NbFichierXLSX = Compteur
End Function

Merci pour votre aide, je sèche..

Nikkss.

 

[nikkss]

Re : Fonction "workbook.open" ne fonctionne pas...

Je viens de trouver..
Désolé pour ce petit couac.
Mes fichiers étaient enregistrés en ".xlsx" alors que c'étaient des ".xlsm".

Résolu!