XL 2010 LIRE DANS FICHIERS FERMES

micheldu52

XLDnaute Occasionnel
Bonjour,

Si quelqu'un peut me mettre sur la piste (VBA ou pas)... ce serait parfait!

La question est la suivante :

Soit un Fichier, disons, maitre.xlsx, et des fichiers esclave1.xlsx, esclave2.xlsxl.... esclave100.xlsx

Chacun à des onglets du même nom, disons que les onglets s'appellent "infos"
Chaque fichier esclave1.... esclave 100 dans son onglet infos à une information spécifique qui figure dans chaque fichier en cellule B2

Comment, dans le fichier maitre puis je lire SANS LES OUVRIR:
1) les informations figurant en B2 de l'onglet infos dans, sur choix proposé, le fichier esclave5.xlsx (par exemple, si le choix s'est porté sur 5)
2) lire toutes les infos de B2 de chaque onglet infos de chaque esclave1... 100 et les reporter dans le fichier maitre dans un onglet "retour" avec le B2 de esclave 1 en C1, le B2 de esclave 2 en C2, le B2 de esclave xy en Cxy

Je galère un peu... (j'arrive à lire telle info dans tel fichier, mais la généralisation me résiste...)

Si je ne suis pas clair je peux déposer des fichiers maitre et 2 esclaves si ca peut aider.

Si vous me donnez le déblocage de cela, je saurai l'adapter à un cas de figure en réalité nettement plus complexe, mais c'est ce point làqui me coince acrtuellement...

Grand merci de m'avoir lu et de votre aide...
Bien cordialement,

Michel
 
Solution
Fichier (2) pour répondre au nouveau problème du post #3 avec cette macro :
VB:
Sub Import()
Dim chemin$, fichier$, feuille$, P As Range, ncol%, resu$(), n&, form$, col%
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
fichier = Dir(chemin & "F*.xlsx") '1er fichier du dossier
feuille = "Infos" 'nom des feuilles sources, à adapter
Set P = [B2:AZ2] 'plage à copier
ncol = P.Count
With Feuil1 'CodeName, à adapter
    ReDim resu(1 To .Rows.Count, 1 To ncol) 'tableau VBA, plus rapide
    While fichier <> ""
        If UCase(fichier) Like "F###*" Then
            n = n + 1
            form = "='" & chemin & "[" & fichier & "]" & feuille & "'!"
            For col = 1 To ncol
                resu(n, col) = form & P(col).Address 'formule de...

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
Bonjour,
Ce fil t'aidera peut-être :)
lionel,
 

micheldu52

XLDnaute Occasionnel
Bonsoir,
Merci. Oui cela m'aide et répond en partie à ma recherche.

Ce code permet (sauf erreur) de récupérer un onglet (ou un autre, Rendez-vous ou données) dans un fichier.

Ce que je voudrais c'est récupérer une info dans un fichier (B2 dans mon exemple plus haut, mais dans la réalité c'est une ligne d'info située de B2 à AZ2) et la recopier dans mon fichier maitre.
Je voudrais "automatiquement" aller la récupérer dans tous les fichiers du répertoire (fichiers que dans mon exemple plus haut j'ai appelé esclave1 esclave2 jusque esclave100, leurs noms seront constitués de façon identique en syntaxe: leur nom sera FxxxPARTIEPERSONNALISEEDUNOMDEFICHIERAUFINDEPUBLIPOSTAGEAUTOMATISE.xlsx)ou xxx représente un nombre de 001 a 999 unique par utilisateur

Mon problème réside dans cette "récupération" en une seule opération sur les fichiers présents (il peut y avoir les 1000, mais il peut y en avoir moins à un instant T (je trouverais un moyen de détecter les fichiers manquants aux fins de relance des retardataires qui n'ont pas rendu..., mais si une âme charitable me guide...)

Ce code est donc parfait pour la récupération d'un fichier, et je peux l'adapter à ce titre, mais il faudrait qu'il récupère tous les fichiers dans la même macro et ca.... je sais pas faire !

Si tu as une piste...

Bien cordialement,

Michel
 

job75

XLDnaute Barbatruc
Bonsoir micheldu52, Lionel,

Je n'aime pas le mot "esclave", je l'ai remplacé par "Source".

Téléchargez les fichiers joints dans le même dossier et voyez cette macro affectée au bouton :
VB:
Sub Import()
Dim chemin$, fichier$, feuille$, cel$, resu$(), n&
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
fichier = Dir(chemin & "Source*.xlsx") '1er fichier du dossier
feuille = "Infos" 'nom des feuilles sources, à adapter
cel = "B2" 'adresse de la cellule à copier
With Feuil1 'CodeName, à adapter
    ReDim resu(1 To .Rows.Count, 1 To 1) 'tableau VBA, plus rapide
    While fichier <> ""
        n = n + 1
        resu(n, 1) = "='" & chemin & "[" & fichier & "]" & feuille & "'!" & cel 'formule de liaison
        fichier = Dir 'fichier suivant
    Wend
    '---restitution---
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    With .[C1] '1ère cellule de destination, à adapter
        If n Then
            With .Resize(n)
                .Formula = resu
                .Value = .Value 'supprime les formules
                .Replace 0, "", xlWhole 'supprime les zéros
                .Interior.ColorIndex = 6 'jaune
                .Borders.Weight = xlHairline 'bordures
            End With
        End If
        .Offset(n).Resize(.Parent.Rows.Count - n - .Row + 1).Delete xlUp 'RAZ en dessous
        .EntireColumn.AutoFit 'ajuste la largeur
    End With
    With .UsedRange: End With 'actualise la barre de défilement verticale
End With
End Sub
A+
 

Pièces jointes

  • Import(1).xlsm
    19.4 KB · Affichages: 16
  • Source1.xlsx
    8.3 KB · Affichages: 3
  • Source2.xlsx
    8.4 KB · Affichages: 3

job75

XLDnaute Barbatruc
Fichier (2) pour répondre au nouveau problème du post #3 avec cette macro :
VB:
Sub Import()
Dim chemin$, fichier$, feuille$, P As Range, ncol%, resu$(), n&, form$, col%
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
fichier = Dir(chemin & "F*.xlsx") '1er fichier du dossier
feuille = "Infos" 'nom des feuilles sources, à adapter
Set P = [B2:AZ2] 'plage à copier
ncol = P.Count
With Feuil1 'CodeName, à adapter
    ReDim resu(1 To .Rows.Count, 1 To ncol) 'tableau VBA, plus rapide
    While fichier <> ""
        If UCase(fichier) Like "F###*" Then
            n = n + 1
            form = "='" & chemin & "[" & fichier & "]" & feuille & "'!"
            For col = 1 To ncol
                resu(n, col) = form & P(col).Address 'formule de liaison
            Next
        End If
        fichier = Dir 'fichier suivant
    Wend
    '---restitution---
    Application.ScreenUpdating = False
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    With .[C1] '1ère cellule de destination, à adapter
        If n Then
            With .Resize(n, ncol)
                .Formula = resu
                .Value = .Value 'supprime les formules
                .Replace 0, "", xlWhole 'supprime les zéros
                .Interior.ColorIndex = 6 'jaune
                .Borders.Weight = xlHairline 'bordures
            End With
        End If
        .Offset(n).Resize(.Parent.Rows.Count - n - .Row + 1, ncol).Delete xlUp 'RAZ en dessous
        .Resize(, ncol).EntireColumn.AutoFit 'ajuste les largeurs
    End With
    With .UsedRange: End With 'actualise la barre de défilement verticale
End With
End Sub
 

Pièces jointes

  • Import(2).xlsm
    20.6 KB · Affichages: 2
  • F001.xlsx
    8.8 KB · Affichages: 2
  • F002.xlsx
    8.8 KB · Affichages: 2
Dernière édition:

micheldu52

XLDnaute Occasionnel
Bonsoir,
Grand merci!
Source est plus élégant en effet!
Ca marche avec n fichiers, bravo et merci!

J'ai ajouté pour récupérer la cellule C2 (voir plus bas) et ca marche mais comme je dois aller jusqu'à AZ2 mon "bricolage" qui marche n'est pas très satisfaisant (50 colonnes...)
J'ai fais des essais avec des : pour définir des plages, mais sans grand succès....

Merci pour cette seconde aide, avec celle de début de semaine cela me permet de passer les difficultés qui se présentent sur le vrai fichier....

Bien cordialement,

Michel







Option Explicit

Sub Import()
Dim chemin$, fichier$, feuille$, cel$, resu$(), n$, resw$(), cew$
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
fichier = Dir(chemin & "Source*.xlsx") '1er fichier du dossier
feuille = "Infos" 'nom des feuilles sources, à adapter
cel = "B2" 'adresse de la premiére cellule à copier
cew = "C2" 'adresse de la deuxiéme cellule à copier sachant que la dernière est AZ2
n = 0
With Feuil1 'CodeName, à adapter
ReDim resu(1 To .Rows.Count, 1 To 1) 'tableau VBA, plus rapide
ReDim resw(1 To .Rows.Count, 1 To 1)
While fichier <> ""
n = n + 1
resu(n, 1) = "='" & chemin & "[" & fichier & "]" & feuille & "'!" & cel 'formule de liaison
resw(n, 1) = "='" & chemin & "[" & fichier & "]" & feuille & "'!" & cew 'formule de liaison
fichier = Dir 'fichier suivant
Wend
'---restitution---
If .FilterMode Then .ShowAllData 'si la feuille est filtrée
With .[C1] '1ère cellule de destination, à adapter
If n Then
With .Resize(n)
.Formula = resu
.Value = .Value 'supprime les formules
.Replace 0, "", xlWhole 'supprime les zéros
.Interior.ColorIndex = 6 'jaune
.Borders.Weight = xlHairline 'bordures
End With
End If
.Offset(n).Resize(.Parent.Rows.Count - n - .Row + 1).Delete xlUp 'RAZ en dessous
.EntireColumn.AutoFit 'ajuste la largeur
End With
With .[d1] '2ème cellule de destination, à adapter
If n Then
With .Resize(n)
.Formula = resw
.Value = .Value 'supprime les formules
.Replace 0, "", xlWhole 'supprime les zéros
.Interior.ColorIndex = 6 'jaune
.Borders.Weight = xlHairline 'bordures
End With
End If
.Offset(n).Resize(.Parent.Rows.Count - n - .Row + 1).Delete xlUp 'RAZ en dessous
.EntireColumn.AutoFit 'ajuste la largeur
End With
With .UsedRange: End With 'actualise la barre de défilement verticale
End With
End Sub
 

micheldu52

XLDnaute Occasionnel
Génial, j'ai tout suivi !
J'adapte dans les prochains jours au "vrai fichier", votre aide me permet d'avancer à grand pas!
A l'arrivée (encore pas mal de travail quand même pour tout paramétrer finement....) un énorme (et le terme est faible) gain de temps et d'efficacité pour moi même et toutes les personnes qui vont utiliser...
A priori, avec votre aide, je pense que j'ai les clefs pour tout faire; mais on ne sait jamais,le diable se cache dans les détails....
Encore une fois merci !
 

micheldu52

XLDnaute Occasionnel
J'étais allé dormir...
Merci!
Temps record !
Encore une fois génial!
Dans les prochaines semaines mon applicatif sera en test grandeur nature, mais c'est déjà plus que prometteur à cette étape d'écriture! Cela va simplifier des traitements "à la main" en quantités énormes.... gain de temps et d'efficacité majeur ! Encore plusieurs heures d'écriture, de débugage cependant!
 

job75

XLDnaute Barbatruc
Bonjour micheldu52, le forum,

Contrairement à ce que je pensais ce n'est pas plus rapide avec le tableau VBA resu.

Avec 999 fichiers sources cette macro du fichier (3) s'exécute en 2,8 secondes :
VB:
Sub Import()
Dim chemin$, fichier$, feuille$, P As Range, ncol%, adr$, dest As Range, n&
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
fichier = Dir(chemin & "F*.xlsx") '1er fichier du dossier
feuille = "Infos" 'nom des feuilles sources, à adapter
Set P = [B2:AZ2] 'plage à copier
ncol = P.Count
adr = P.Address
Application.ScreenUpdating = False
With Feuil1 'CodeName, à adapter
    Set dest = .[C1] '1ère cellule de destination, à adapter
    While fichier <> ""
        If UCase(fichier) Like "F###*" Then
            n = n + 1
            dest(n).Resize(, ncol).FormulaArray = "='" & chemin & "[" & fichier & "]" & feuille & "'!" & adr 'formule de liaison matricielle
        End If
        fichier = Dir 'fichier suivant
    Wend
    '---finalisation---
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    If n Then
        With dest.Resize(n, ncol)
            .Value = .Value 'supprime les formules
            .Replace 0, "", xlWhole 'supprime les zéros
            .Interior.ColorIndex = 6 'jaune
            .Borders.Weight = xlHairline 'bordures
        End With
    End If
    dest.Offset(n).Resize(.Rows.Count - n - dest.Row + 1, ncol).Delete xlUp 'RAZ en dessous
    On Error Resume Next 'dest a été supprimée si le tableau est vide (n=0)
    dest.Resize(, ncol).EntireColumn.AutoFit 'ajuste les largeurs
    With .UsedRange: End With 'actualise la barre de défilement verticale
End With
End Sub
Le gain de temps est dû au fait qu'il y a une seule formule - matricielle - par ligne.

Donc utilisez cette solution.

A+
 

Pièces jointes

  • Import(3).xlsm
    20.7 KB · Affichages: 3
  • F001.xlsx
    8.8 KB · Affichages: 2
  • F002.xlsx
    8.8 KB · Affichages: 2

Discussions similaires

Haut Bas