Fichier centralisateur de plusieurs fichiers

Le 14/10/2020 à 13:15

Bonjour,

Je cherche à écrire une procédure à partir du fichier centralisateur (Destination) pour importer par copier-coller les données se trouvant sur plusieurs fichiers Source.

Les fichiers Destination et Sources ont la même structure.

Ma logique:
Pour chaque fichier Source,
Pour chaque ligne de Source,
Si Cellule date renseignée, alors
Pour chaque ligne de Destination,
Si Code Destination = Code Source, alors
Copier cellules Source
Coller dans cellules Destination
Ligne Destination suivante
Ligne Source suivante
Fichier Source suivant.

La procédure suivante (partie en italique de "Ma logique") fonctionne correctement avec un seul fichier Source:

'en ayant ouvert les fichiers Sources
Sub MiseAjour()

    Dim wDest As Workbook 'déclare le fichier de Destination
    Dim fDest As Worksheet 'déclare la feuille du fichier de Destination
    Dim lgDe As Integer  'déclare le nombre de lignes du fichier Destination
    Dim wOrig As Workbook 'déclare le fichier Source
    Dim fOrig As Worksheet 'déclare la feuille du fichier Source
    Dim lgOr As Integer  'déclare le nombre de ligne du fichier Source

    Application.ScreenUpdating = False  'désactive le rafraichissement de l'écran, accélère la procédure

     Set wDest = Workbooks("AAAAA.xlsm") 'définit le fichier de Destination AAAAA
     Set fDest = Workbooks("AAAAA.xlsm").Sheets("Base") 'définit la feuille "Base" du fichier de Destination AAAAA
     Set wOrig = Workbooks("AAAAA01.xlsm") 'définit le fichier Source AAAAA01
     Set fOrig = Workbooks("AAAAA01.xlsm").Sheets("Base") 'définit la feuille "Base" du fichier Source AAAAA01

    For lgOr = 4 To fOrig.Range("A" & Rows.Count).End(xlUp).Row 'Pour chaque ligne du fichier Source
        If fOrig.Range("L" & lgOr) <> "" Then   'Si date réalisée renseignée
            For lgDe = 4 To fDest.Range("A" & Rows.Count).End(xlUp).Row 'Pour chaque ligne du fichier Destination
                If Range("A" & lgDe) = fOrig.Range("A" & lgOr) Then 'Si N°Code en Destination = N°Code en Source, alors
                    Range("L" & lgOr).Copy  'Copier la cellule Source
                    fDest.Range("L" & lgDe).PasteSpecial xlPasteValues  'Coller valeur dans cellule Destination
                    fDest.Range("L" & lgDe).PasteSpecial xlPasteFormats 'Coller format dans cellule Destination
                    Range("AE" & lgOr & ":AU" & lgOr).Copy 'Copier la plage Source
                    fDest.Range("AE" & lgDe).PasteSpecial xlPasteValues  'Coller valeur de la plage à partir de la 1ère cellule Destination
                    fDest.Range("AE" & lgDe).PasteSpecial xlPasteFormats 'Coller valeur de la plage à partir de la 1ère cellule Destination
                End If
            Next lgDe   'à la prochaine ligne de Destination
        End If
    Next lgOr   'à la prochaine ligne de Source

    Application.ScreenUpdating = True  'réactive le rafraichissement de l'écran

End Sub

Ma question : comment boucler pour appeler tous les fichiers Source AAAAA01 à AAAAA20 situés dans un même dossier ?

Merci pour votre aide,

Cordialement

Le 14/10/2020 à 17:25

Bonjour,

une proposition d'adaptation (non testée). Suppose que tous les fichiers à triater soient ouverts dans la même instance d' excel avant exécution de la macro.

'en ayant ouvert les fichiers Sources
Sub MiseAjour()

    Dim wDest As Workbook 'déclare le fichier de Destination
    Dim fDest As Worksheet 'déclare la feuille du fichier de Destination
    Dim lgDe As Long 'déclare le nombre de lignes du fichier Destination
    Dim wOrig As Workbook 'déclare le fichier Source
    Dim fOrig As Worksheet 'déclare la feuille du fichier Source
    Dim lgOr As Long 'déclare le nombre de ligne du fichier Source
    Dim nf As Long 'numéro de fichier à traiter

    Application.ScreenUpdating = False  'désactive le rafraichissement de l'écran, accélère la procédure

    Set wDest = Workbooks("AAAAA.xlsm") 'définit le fichier de Destination AAAAA
    Set fDest = Workbooks("AAAAA.xlsm").Sheets("Base") 'définit la feuille "Base" du fichier de Destination AAAAA

    For nf = 1 To 20 'on traite les fichiers 1 à 20
        Set wOrig = Workbooks("AAAAA" & Format(nf, "00") & ".xlsm") 'définit le fichier Source AAAAAxx
        Set fOrig = wOrig.Sheets("Base") 'définit la feuille "Base" du fichier Source AAAAAxx

        For lgOr = 4 To fOrig.Range("A" & Rows.Count).End(xlUp).Row 'Pour chaque ligne du fichier Source
            If fOrig.Range("L" & lgOr) <> "" Then   'Si date réalisée renseignée
                For lgDe = 4 To fDest.Range("A" & Rows.Count).End(xlUp).Row 'Pour chaque ligne du fichier Destination
                    If fdest.Range("A" & lgDe) = fOrig.Range("A" & lgOr) Then 'Si N°Code en Destination = N°Code en Source, alors
                        forig.Range("L" & lgOr).Copy  'Copier la cellule Source
                        fDest.Range("L" & lgDe).PasteSpecial xlPasteValues  'Coller valeur dans cellule Destination
                        fDest.Range("L" & lgDe).PasteSpecial xlPasteFormats 'Coller format dans cellule Destination
                        forig.Range("AE" & lgOr & ":AU" & lgOr).Copy 'Copier la plage Source
                        fDest.Range("AE" & lgDe).PasteSpecial xlPasteValues  'Coller valeur de la plage à partir de la 1ère cellule Destination
                        fDest.Range("AE" & lgDe).PasteSpecial xlPasteFormats 'Coller valeur de la plage à partir de la 1ère cellule Destination
                    End If
                Next lgDe   'à la prochaine ligne de Destination
            End If
        Next lgOr   'à la prochaine ligne de Source
    Next nf
    Application.ScreenUpdating = True  'réactive le rafraichissement de l'écran

End Sub

Le 14/10/2020 à 22:31

Bonsoir H2SO4,

Merci beaucoup pour votre solution que j'ai bien comprise.

La procédure remplit bien le fichier Destination AAAAA, mais en cours d'exécution apparaît le message "Erreur d'exécution 9, L'indice n'appartient pas à la sélection".

En débogant, j'obtiens cette ligne surlignée en jaune :

        Set wOrig = Workbooks("AAAAA" & Format(nf, "00") & ".xlsm") 'définit le fichier Source AAAAAxx

J'ai essayé en enregistrant les fichiers par AAAAA1 et AAAAA2 au lieu de AAAAA01 et AAAAA02, et en corrigeant la ligne par :

Set wOrig = Workbooks("AAAAA" & nf & ".xlsm") 'définit le fichier Source AAAAAxx

Mais le message d'erreur se reproduit.

Qu'en pensez-vous ?

Cordialement,

Le 14/10/2020 à 23:18

Désolé H2SO4,

Je faisais mes essais avec seulement 2 fichiers Sources AAAAA01 et AAAAA02, et non 20 comme nécessaire à terme.
J'ai alors fait un essai avec For nf =1 to 2, au lieu de For nf = 1 to 20, et là, ça marche sans message d'erreur !
Merci donc pour cette boucle élégante !

Pour aller plus loin, que faudrait-il ajouter pour réaliser les mêmes opérations mais à partir de fichiers fermés dans un dossier unique AAAAAXX ?

Aller au dossier AAAAAXX des fichiers AAAAA01 à AAAAA20
Pour chaque fichier
Ouvrir le fichier
Exécuter la boucle
Fermer le dossier
Fichier suivant

Merci encore si vous pouviez me mettre sur la voie !

Cordialement

Le 15/10/2020 à 00:04

bonsoir,

adaptation du code pour ouvrir fichiers source (adapter le nom du répertoire dans le code ci-dessous). non testé.

'en ayant ouvert les fichiers Sources
Sub MiseAjour()

    Dim wDest As Workbook 'déclare le fichier de Destination
    Dim fDest As Worksheet 'déclare la feuille du fichier de Destination
    Dim lgDe As Long 'déclare le nombre de lignes du fichier Destination
    Dim wOrig As Workbook 'déclare le fichier Source
    Dim fOrig As Worksheet 'déclare la feuille du fichier Source
    Dim lgOr As Long 'déclare le nombre de ligne du fichier Source
    Dim nf As Long 'numéro de fichier à traiter
    Dim repertoire As String
    Dim nomfichier As String
    Application.ScreenUpdating = False  'désactive le rafraichissement de l'écran, accélère la procédure

    repertoire = "c:\nom du répertoire contenant les fichiers source" ' <--------------------------------------------à adapter

    Set wDest = Workbooks("AAAAA.xlsm") 'définit le fichier de Destination AAAAA
    Set fDest = Workbooks("AAAAA.xlsm").Sheets("Base") 'définit la feuille "Base" du fichier de Destination AAAAA

    For nf = 1 To 20 'on traite les fichiers 1 à 20
    nomfichier = repertoire & "\AAAAA" & Format(nf, "00") & ".xlsm" 'définit le fichier Source AAAAAxx

        Set wOrig = Workbooks.Open(nomfichier)  ' ouverture du classeur

        Set fOrig = wOrig.Sheets("Base") 'définit la feuille "Base" du fichier Source AAAAAxx

        For lgOr = 4 To fOrig.Range("A" & Rows.Count).End(xlUp).Row 'Pour chaque ligne du fichier Source
            If fOrig.Range("L" & lgOr) <> "" Then   'Si date réalisée renseignée
                For lgDe = 4 To fDest.Range("A" & Rows.Count).End(xlUp).Row 'Pour chaque ligne du fichier Destination
                    If fDest.Range("A" & lgDe) = fOrig.Range("A" & lgOr) Then 'Si N°Code en Destination = N°Code en Source, alors
                        fOrig.Range("L" & lgOr).Copy  'Copier la cellule Source
                        fDest.Range("L" & lgDe).PasteSpecial xlPasteValues  'Coller valeur dans cellule Destination
                        fDest.Range("L" & lgDe).PasteSpecial xlPasteFormats 'Coller format dans cellule Destination
                        fOrig.Range("AE" & lgOr & ":AU" & lgOr).Copy 'Copier la plage Source
                        fDest.Range("AE" & lgDe).PasteSpecial xlPasteValues  'Coller valeur de la plage à partir de la 1ère cellule Destination
                        fDest.Range("AE" & lgDe).PasteSpecial xlPasteFormats 'Coller valeur de la plage à partir de la 1ère cellule Destination
                        'exit for ' si ligne trouvée on peut sortir de la boucle
                    End If
                Next lgDe   'à la prochaine ligne de Destination
            End If
        Next lgOr   'à la prochaine ligne de Source

        wOrig.Close False 'fermeture du classeur

    Next nf
    Application.ScreenUpdating = True  'réactive le rafraichissement de l'écran

End Sub

Le 15/10/2020 à 09:18

Bonjour H2SO4,

Merci beaucoup pour votre aide qui est allée jusqu'à écrire les lignes !
J'apprécie votre pédagogie par l'exemple juste, la logique du code est très claire.
J'ai encore appris sur l'usage des variables, ce qui me gêne encore pour passer de l'idée à la réalisation !

Votre adaptation a parfaitement fonctionné au premier essai.

Je suppose que le Exit for en commentaire était une suggestion. Je l'ai placé en ligne de code et le programme s'est bien déroulé. Je pourrais placer un timer pour tester le gain de temps en conditions réelles sur 2000 lignes.

Encore merci !

Bonne journée

Le 15/10/2020 à 11:44

bonjour

Je suppose que le Exit for en commentaire était une suggestion.

En effet.

Si les performances posent problèmes, il est encore possible d'améliorer significativement l'efficacité du code. Si chaque fichier contient environ 2000 lignes et en supposant qu'il n'y ait que 25% de lignes avec une date, la macro devrait lire 20*2000*(2000*50%*25%) lignes soit 10.000.000 de lignes. (20.000.000 sans le exit for). On peut réduire ce nombre à 21*2000 soit 42.000 lignes lues.

Le 15/10/2020 à 13:22

Quantification intéressante...

Proposeriez-vous une autre architecture de la procédure ?

Le 15/10/2020 à 13:59

bonjour,

une autre architecture de la procédure (utilise l'objet dictionnaire, non disponible sur MAC). non testée

'en ayant ouvert les fichiers Sources
Sub MiseAjour()

    Dim wDest As Workbook 'déclare le fichier de Destination
    Dim fDest As Worksheet 'déclare la feuille du fichier de Destination
    Dim lgDe As Long 'déclare le nombre de lignes du fichier Destination
    Dim wOrig As Workbook 'déclare le fichier Source
    Dim fOrig As Worksheet 'déclare la feuille du fichier Source
    Dim lgOr As Long 'déclare le nombre de ligne du fichier Source
    Dim nf As Long 'numéro de fichier à traiter
    Dim repertoire As String
    Dim nomfichier As String
    Dim dict As Object

    Set dict = CreateObject("scripting.dictionary") 'on utilise un dictionnaire pour retrouver rapidement le numéro de ligne d'un libellé

    Application.ScreenUpdating = False  'désactive le rafraichissement de l'écran, accélère la procédure

    For lgDe = 4 To fDest.Range("A" & Rows.Count).End(xlUp).Row 'Pour chaque ligne du fichier Destination
        dict(fDest.Range("A" & lgDe).Value) = lgDe 'on associe n° de ligne et libellé du fichier destination
    Next lgDe   'à la prochaine ligne de Destination

    repertoire = "c:\nom du répertoire contenant les fichiers source" ' <--------------------------------------------à adapter

    Set wDest = Workbooks("AAAAA.xlsm") 'définit le fichier de Destination AAAAA
    Set fDest = Workbooks("AAAAA.xlsm").Sheets("Base") 'définit la feuille "Base" du fichier de Destination AAAAA

    For nf = 1 To 20 'on traite les fichiers 1 à 20
        nomfichier = repertoire & "\AAAAA" & Format(nf, "00") & ".xlsm" 'définit le fichier Source AAAAAxx

        Set wOrig = Workbooks.Open(nomfichier)  ' ouverture du classeur

        Set fOrig = wOrig.Sheets("Base") 'définit la feuille "Base" du fichier Source AAAAAxx

        For lgOr = 4 To fOrig.Range("A" & Rows.Count).End(xlUp).Row 'Pour chaque ligne du fichier Source
            If fOrig.Range("L" & lgOr) <> "" Then   'Si date réalisée renseignée
                lgDe = dict(fOrig.Range("A" & lgOr).Value) 'on recherche le n° de ligne associé au libellé de la ligne d'origine
                fOrig.Range("L" & lgOr).Copy  'Copier la cellule Source
                fDest.Range("L" & lgDe).PasteSpecial xlPasteValues  'Coller valeur dans cellule Destination
                fDest.Range("L" & lgDe).PasteSpecial xlPasteFormats 'Coller format dans cellule Destination
                fOrig.Range("AE" & lgOr & ":AU" & lgOr).Copy 'Copier la plage Source
                fDest.Range("AE" & lgDe).PasteSpecial xlPasteValues  'Coller valeur de la plage à partir de la 1ère cellule Destination
                fDest.Range("AE" & lgDe).PasteSpecial xlPasteFormats 'Coller valeur de la plage à partir de la 1ère cellule Destination
            End If
        Next lgOr   'à la prochaine ligne de Source

        wOrig.Close False 'fermeture du classeur

    Next nf
    Application.ScreenUpdating = True  'réactive le rafraichissement de l'écran

End Sub

Il est encore possible d'améliorer les performances en évitant au maximum les interactions avec la feuille de calcul excel (instructions de lecture de cellule, de copy, de paste ... qui sont les plus pénalisantes d'un point de vue performances), mais pour ces améliorations, il faut les faire en connaissant la structure et la mise en page du fichier (si la mise en page est importante)

Le 15/10/2020 à 14:22

Merci H2SO4,

Vous m'ouvrez de nouvelles pistes d'étude !

Je regarderai votre dernière proposition dans un moment, lorsque je serai moins pris par le chrono !

Merci encore et bonne après-midi.

Rechercher des sujets similaires à "fichier centralisateur fichiers"