import fichiers dans plusieurs dossiers

[KIM]

Bonjour les ami(e)s, Bonjour le forum,
Comme à l'habitude je reviens vers vous pour vous solliciter et je vous en remercie d'avance. Dans un dossier j'ai des sous dossiers dans lesquels j'ai beaucoup de fichiers excel. le nom de certains fichiers excel , plus de 2000, se termine par SURF.xls et possedent la meme structure de données. Je dois récupérer ces données dans le fichier nommé RecapGlobal_v1. Les données à récupérer sont de 2 types:
1- Recopier de chaque fichier ....SURF.xls les données de la ligne 9, à la colonne U, dans l'onglet RecapG du fichier RecapGlobal_v1.
2- les 7 premières lignes, col B de chaque fichier à recopier dans RecapGlobal_v1, onglet RecapSG en ligne (transposé), avec nom du fichier et nom de l'onglet copié.
voir fichier ci-joint.
Merci d'avance
KIM

 

[KIM]

Re : import fichiers dans plusieurs dossiers

Re, le fil
@Softmama,
Merci beaucoup Softmama. Je vais bientôt tester la macro sur l'ensemble des fichiers (~2000) dès leur disponibilité au même format décrit précédemment et je me permets de revenir sur ce fil si nécessaire.
Merci encore.
KIM

 

[KIM]

Re : import fichiers dans plusieurs dossiers

Re, le fil
@Softmama,
En attendant de tester la macro sur l'ensemble des fichiers. J'ai dans le répertoire un autre type de fichiers excel à récupérer. Ces fichiers excel ont le même nom exactement que le répertoire du fichier. Je n'ai pas réussi à modifier la ligne de ton code.
2 cas se présentent: comment modifier la macro
1- pour lire seulement les fichiers du m^me nom que le répertoire?
2- pour lire seulement les fichiers dont le nom est composé de 8 caractères (ex AD01.xls) dont les 2 premiers sont toujours "AD"?
Merci de votre aide
2-

 

[Softmama]

Re : import fichiers dans plusieurs dossiers

Bonjour,

Vois le fichier modifié, j'ai mis des annotations dans le code pour que tu puisses l'adapter aux différents cas que tu évoques. Avec ceci, tu devrais pouvoir t'en sortir, fais moi savoir si tu rencontres des soucis.

 

[KIM]

Re : import fichiers dans plusieurs dossiers

Re, le fil
Merci Softmama. J'ai testé les 2 cas, impeccables.
Par contre je viens de remarquer que la dernière ligne des colonnes A, B et c des onglets RecapG et RecapB ne sont pas recopier.
J'ai reçu l'ensemble des fichiers. Je vais lancer d'ici demain le traitement et je te tiendrai au courant.
Merci encore de ton aide et surtout de ta réactivité.
KIM

 

[KIM]

Re : import fichiers dans plusieurs dossiers

Re, Softmama, Staple1600, et le forum
@Softmama,
J'ai récupéré 1480 fichiers en 15 minutes. Mille mercis. Je n'ose même pas imaginer le temps nécessaire poir fiare une recopie manuelle de tous ses fichiers.

@Softmama, Staple1600 & le forum
Au début de ce fil Staple1600 m'a suggéré de regarder les différents fils à ce sujet sur le forum. La macro de Softmama ouvre chaque fichier, lit et recopie le contenu et referme le fichier. Elle tourne bien.
Pour ma lanterne, je souhaite recopier le contenu de ses fichiers, fermés, sans les ouvrir.
Par exemple en utilsant la notion de ".formula"
ActiveCell.Offset(0, 1) = f.Name.Sheets(1).[A9].CurrentRegion.Paste
With ActiveCell.Offset(0, 1)
.Formula = "='f.Name.Sheets(1)" & "'!" & "A9:V100"
.Value = .Value
End With
Je n'ai pas réussi à transformer la macro de Softmama pour lire ces fichiers fermés sans les ouvrir.
Merci d'avance de votre aide
KIM

 

[Softmama]

Re : import fichiers dans plusieurs dossiers

Bonjour Kim, Staple1600, le forum,

Heureux que la macro ait fonctionné pour tes besoins.
Pour mettre un lien vers le fichier fermé, essaie de remplacer :

With ActiveCell.Offset(0, 1)
.Formula = "='f.Name.Sheets(1)" & "'!" & "A9:V100"
.Value = .Value
End With

par

for x=1 to 22
  for t=9 to 100
    with activecell.offset(t-8,x-1)
      .Formula = "='[" & f.Name & "]" & workbooks(f.Name).Sheets(1).Name & "'!" & chr(64+x) & t
      .Value = .Value
    end with
  Next
next

à tester, pque là, je l'ai pas fait 🙄

 

[Staple1600]

Re : import fichiers dans plusieurs dossiers

Bonjour Kim, SoftMama, le fil, le forum

Bonsoir KIM, le fil, le forum
Bravo pour l'initiative de recherche d'infos et d'exemples 😉
Je vais essayer de trouver du temps pour voir exactement il retourne

Du temps, je n'en ai pas trouvé. 😱

Heureusement, le relais a été brillamment pris par SoftMama.

 

[KIM]

Re : import fichiers dans plusieurs dossiers

Re, Softmama, Staple1600, et le forum
@Softmama,
J'ai testé ton code mais je n'ai pas réussi à le faire tourner pour avoir le résultat souhaité. Si tu as le temps etje t'en remercie d'avance, est-i possible de l'intégrer dans ton code initial dans le fichier de ma demande n°20 de ce jour.
Merci d'avance
KIM

 

[Softmama]

Re : import fichiers dans plusieurs dossiers

Bonsoir Kim,

J'ai remanié le fichier de la façon dont tu me l'as indiqué : désormais, la macro n'ouvre pas les fichiers, mais va pointer direct dedans via une formule du genre :

='" & Répertoire & "\[" & Fichier.Name & "]" & nOnglet & "'!A" & t

où t est le numéro de ligne jusqu'à temps que la cellule soit vide auquel cas, je passe au fichier suivant. Seul souci comme cela, c'est de récupérer le nom de l'onglet qui change à chaque fichier. J'ai donc du créer cette fonction pour chercher sans ouvrir les classeurs le nom de leur 1er onglet :

Function RechFermé(Fichier As String)
'Reccueille le nom des onglets des fichiers .xls sans les ouvrir.
'Nécessite d'activer la référence Microsoft ADO ext x.x for DLL and Security
'Nécessite d'activer la référence Microsoft ActiveX Data Objects x.x Library
    Dim Cn As ADODB.Connection
    Dim oCat As ADOX.Catalog
    Dim Resultat As String
    Dim Feuille As ADOX.Table
    Set Cn = New ADODB.Connection
    Set oCat = New ADOX.Catalog
    Cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Fichier & ";Extended Properties=Excel 8.0;"
    Set oCat.ActiveConnection = Cn
    Set Feuille = oCat.Tables(0) 'Récupération du nom du 1er Onglet du fichier pour travailler dessus
    RechFermé = Left$(Feuille.Name, Len(Feuille.Name) - 1)
    RechFermé = Mid(RechFermé, 2, Len(RechFermé) - 2)
    Set Feuille = Nothing
    Set oCat = Nothing
    Cn.Close
    Set Cn = Nothing
End Function

Note que pour fonctionner, il faut sélectionner dans Outils/Références ces 2 références :
Microsoft ADO ext x.x for DLL and Security
Microsoft ActiveX Data Objects x.x Library

Les macros Go et QuelRépertoire restent inchangés, la macro recopie a vu quelques modifs:

Sub Recopie(Répertoire)
    Dim c As Range, nOnglet As String
    Dim Fso As Scripting.FileSystemObject
    Dim RépSource As Scripting.Folder
    Dim SousRép As Scripting.Folder
    Dim Fichier As Scripting.File
    
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set RépSource = Fso.GetFolder(Répertoire)
    Application.ScreenUpdating = False
    Sheets("RecapG").Range("B3") = Sheets("RecapG").Range("B3") + 1
    For Each Fichier In RépSource.Files
        If Right$(Fichier, 8) = "SURF.xls" Then 'Recherche des fichiers *SURF.xls
            Set c = Sheets("RecapG").Range("d" & Sheets("RecapG").Range("d65536").End(xlUp).Row + 1)
            Range("B4") = Range("B4") + 1
            nOnglet = RechFermé(RépSource & "\" & Fichier.Name) 'ADO Pour trouver le nom du 1er onglet
            t = 8
1           t = t + 1
            c.Offset(t - 9, 0).Formula = "='" & Répertoire & "\[" & Fichier.Name & "]" & nOnglet & "'!A" & t
                If c.Offset(t - 9, 0).Value = 0 Then c.Offset(t - 9, 0).Clear Else GoTo 1
                t = t - 1
                Range(c, c(t - 8, 1)).AutoFill Range(c, c(t - 8, 23))
                Range(c, c(t - 8, 23)).Value = Range(c, c.Offset(t - 8, 22)).Value
                c(1, -2).Resize(t - 8) = Répertoire
                c(1, -1).Resize(t - 8) = Fichier.Name
                c(1, 0).Resize(t - 8) = nOnglet
        End If
    Next Fichier
    '--- Appel récursif pour lister les fichier dans les sous-répertoires ---.
    For Each SousRép In RépSource.subfolders
        Recopie SousRép.Path
    Next SousRép
End Sub

Note que la macro, à l'état actuel ne gère que la feuille RecapG. Pour la feuille RecapSG, il devrait t'être facile de la rajouter sur le même principe, ou sinon je te le ferai demain.

cf. fichier joint
N'hésite pas si pbs... et suis curieux de savoir quel gain de temps cette formule procure sur la quantité de fichiers que tu as à traiter par rapport à l'ancienne.Ce lien n'existe plus

 

[KIM]

Re : import fichiers dans plusieurs dossiers

Bonsoir Softmama & le fil,
Merci pour cette adaptation avec les fichiers fermés. Pour pouvoir tester début semaine prochaine les 2 macros, il me manque la partie qui consiste à remplir la feuille "RecapSG" avec les données B1 à B7 de chaque fichier scanné et les transposer dans D(t) à J(t).
Merci de m'aider à transformer cette partie du code :
With .Sheets("RecapSG")
.Range("A" & .Range("D65536").End(xlUp).Row + 1) = RépSource.Name
.Range("B" & .Range("D65536").End(xlUp).Row + 1) = Fichier.Name
.Range("C" & .Range("D65536").End(xlUp).Row + 1) = ActiveWorkbook.Sheets(1).Name
Sheets(1).Range("B1:B7").Copy
.Range("D" & .Range("D65536").End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
End With
pour utiliser des fichiers fermés (avec .formula)

Merci d'avance
KIM

 

[Softmama]

Re : import fichiers dans plusieurs dossiers

Bonsoir Kim,

Ha oui, j'avais oublié de te le faire, c'est réparé dans cette version (modifs en rouge pour gérer la feuille RecapSG:

Sub Recopie(Répertoire)
    Dim c As Range, [COLOR="Red"]d As Range,[/COLOR] nOnglet As String
    Dim Fso As Scripting.FileSystemObject
    Dim RépSource As Scripting.Folder
    Dim SousRép As Scripting.Folder
    Dim Fichier As Scripting.File
    
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set RépSource = Fso.GetFolder(Répertoire)
    Application.ScreenUpdating = False
    Sheets("RecapG").Range("B3") = Sheets("RecapG").Range("B3") + 1
    For Each Fichier In RépSource.Files
        If Right$(Fichier, 8) = "SURF.xls" Then 'Recherche des fichiers *SURF.xls
[COLOR="Red"]            nOnglet = RechFermé(RépSource & "\" & Fichier.Name) 'ADO Pour trouver le nom du 1er onglet
[/COLOR]            Set c = Sheets("RecapG").Range("D" & Sheets("RecapG").Range("d65536").End(xlUp).Row + 1)
[COLOR="Red"]            Set d = Sheets("RecapSG").Range("D" & Sheets("RecapSG").Range("d65536").End(xlUp).Row + 1)
            d(1, -2) = Répertoire
            d(1, -1) = Fichier.Name
            d(1, 0) = nOnglet
            For t = 1 To 7
                d(1, t).Formula = "='" & Répertoire & "\[" & Fichier.Name & "]" & nOnglet & "'!B" & t
                d = d
            Next t
[/COLOR]            Range("B4") = Range("B4") + 1
            t = 8
1           t = t + 1
            c.Offset(t - 9, 0).Formula = "='" & Répertoire & "\[" & Fichier.Name & "]" & nOnglet & "'!A" & t
                If c.Offset(t - 9, 0).Value = 0 Then c.Offset(t - 9, 0).Clear Else GoTo 1
                t = t - 1
                Range(c, c(t - 8, 1)).AutoFill Range(c, c(t - 8, 23))
                Range(c, c(t - 8, 23)).Value = Range(c, c.Offset(t - 8, 22)).Value
                c(1, -2).Resize(t - 8) = Répertoire
                c(1, -1).Resize(t - 8) = Fichier.Name
                c(1, 0).Resize(t - 8) = nOnglet
        End If
    Next Fichier
    '--- Appel récursif pour lister les fichier dans les sous-répertoires ---.
    For Each SousRép In RépSource.subfolders
        Recopie SousRép.Path
    Next SousRép
End Sub

Vois le fichier joint 🙂

 

[KIM]

Re : import fichiers dans plusieurs dossiers

Bonjour Softmama & le fil,
J'ai testé ta nouvelle macro, Merci beaucoup. Je l'ai testé sur 216 fichiers et 119 dossiers en 16s contre 43s. Je n'ai osé la lancer sur l'ensemble des dossiers car :
1- A la fin de l'exécution de ta dernière macro (scan fichiers fermés), le bouton reste actif. Dès que je clicque à l'extérieur, des liaisons à tous les fichiers scannés sont créées. J'ai remarqué cela quand j'ai sauvegardé le fichier résultat et l'ouvert de nouveau, Excel me demande :
"Le classeur comporte des liaisons avec un autre classeur, Voulez-vous mettre à jour ce classeur"
Est-il possible de supprimer toutes les liaisons créées en fin de procédue?

2- Format des cellules:
Avec la première macro, ouverture des fichiers, copie des données et fermeture des fichiers, je n'ai pas de problème avec le format de certaines cellules.*
Avec ta dernière macro, étage et numéro pièce, les '01 deviennent 1, '07 devient 7. Est-il possible de conserver le format des données.
Merci encore de ta collaboration
KIM

 

[Softmama]

Re : import fichiers dans plusieurs dossiers

Bonjour Kim,

En effet une erreur :
il faut
remplacer la ligne :

d = d

par :

                d(1, t) = d(1,t)

Pour la mise en forme, tu vas être obligé(e) de procéder ainsi :
copier les mises en forme souhaitées pour chaque colonne dans le fichier de récap et afin qu'elles soient conservées, remplacer les
.clear par des .clearcontents

 

[KIM]

Re : import fichiers dans plusieurs dossiers

Bonjour Softmama & le fil,
Les 2 macros ont été lancées sur 1473 fichiers.
Temps d'exécution de la première (avec ouverture et fermeture des fichiers) : 32mn
Temps d'exécution de la seconde avec ADODB.Connection (sans ouvrir les fichiers): 3mn
Rapide !!!

Merci, ton aide a été précieuse.

Par contre je n'ai pas pu résoudre, suite à tes conseils, le problème des '01 qui se transforment en 1 dans l'exécution de la 2ème macro. Si tu as le temps, merci d'avance.
Cordialement
KIM

 

[Softmama]

Re : import fichiers dans plusieurs dossiers

Bonjour Kim,

Pour régler ton souci de mise en forme, une solution qui vaut ce qu'elle vaut :
Place ces lignes à la fin de la macro (juste avant le End Sub) afin de définir le format de cellules qui te plait :

    With Sheets("RecapG")
        .Columns("D:N").NumberFormat = "00;;;Standard"
        .Columns("O:S").NumberFormat = "#0.00"" m²"";;"
        .Columns("T:Z").NumberFormat = "#;#;"
    end With
    Sheets("RecapSG").Columns("D:J").NumberFormat = "0.00;0.00;"

et ainsi, plus de souci !