Modification macro de rassemblement de données

Bonjour,

J'aurai besoin d'un coup de main pour modifier une macro existante. Malheureusement je ne parviens pas à comprendre ce langage, au point ou je n'arrive même pas à situer là où les modifications doivent être faites...

Cette macro rassemble sur une même feuille toutes les données présentes dans les onglets. Mon objectif est de déplacer ces onglets dans des fichiers séparés car il y en aura à terme plusieurs dizaines. Ma première question est de savoir si cela est possible d'aller chercher des données dans d'autres fichiers, et la deuxième de savoir comment modifier la macro en conséquence.

J'ai préparé un fichier exemple (CR5) dans lequel la macro fonctionne localement. Et les futurs fichiers dans lesquels j'aimerai qu'elle aille chercher les données (AAA BBB CCC).

Je vous remercie d'avance en espérant avoir été assez clair.

Bonjour,

vérifie si c'est ok

Option Explicit

    Dim wbk1 As Workbook, wbk2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim rng1 As Range, rng2 As Range

    Dim chemin$, monFichier$, onglet$

Sub maj()

    chemin = ThisWorkbook.Path & "\"

    Set wbk1 = ThisWorkbook
    Set ws1 = ActiveSheet
    ws1.Cells(1).CurrentRegion.Offset(1, 0).ClearContents
    monFichier = Dir(chemin & "*.xlsx")

    Do While monFichier <> ""
        Set wbk2 = Workbooks.Open(chemin & monFichier)
        Set ws2 = ActiveSheet
        Set rng2 = ws2.Cells(1).CurrentRegion
        rng2.Offset(1).Resize(rng2.Rows.Count - 1, rng2.Columns.Count).Copy
        Set rng1 = ws1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        rng1.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        Application.CutCopyMode = False
        wbk2.Close False
        monFichier = Dir
    Loop

    ws1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select

End Sub

Merci pour cette réponse rapide. J'ai essayé la macro seule et les données se remplissent bien. Il reste cependant un problème de format de date et je me retrouve tout en bas à la fin de l’exécution.

Vu que j'aimerai conserver toutes les fonctions de l'ancienne, j'ai donc mis ce que tu as rédigé en remplacement de cette partie dans la macro existante :

Sub maj()
nbonglet = ThisWorkbook.Sheets.Count
balise = 2
Worksheets("Synthèse").Range("A2:P150000").Clear
For onglet = 3 To nbonglet
    ligne = 2
    nbligne = Worksheets(onglet).UsedRange.Rows.Count
    Worksheets("Synthèse").Range("A" & balise & ":F" & balise + nbligne).Value = Worksheets(onglet).Range("A" & ligne & ":F" & nbligne).Value
    balise = balise + nbligne + 1
Next

Maintenant j'ai un message d'erreur dans la boucle suivante, qui me dit que la variable est non définie.

' supprime ligne si #N/A
For i = der_ligne To 1 Step -1
    If Application.IsNA(Cells(i, 2).Value) Then
        Range(Rows(i), Rows(i)).Delete
    End If
Next

Est-ce lié au fait que je me retrouve en bas de la liste ?

APetit a écrit :

je me retrouve tout en bas à la fin de l’exécution.

change alors la dernière instruction comme suit

    ws1.Cells(2, 1).Select

APetit a écrit :

Il reste cependant un problème de format de date

APetit a écrit :

j'ai donc mis ce que tu as rédigé en remplacement de cette partie dans la macro existante :

Sub maj()
nbonglet = ThisWorkbook.Sheets.Count
balise = 2
Worksheets("Synthèse").Range("A2:P150000").Clear
For onglet = 3 To nbonglet
    ligne = 2
    nbligne = Worksheets(onglet).UsedRange.Rows.Count
    Worksheets("Synthèse").Range("A" & balise & ":F" & balise + nbligne).Value = Worksheets(onglet).Range("A" & ligne & ":F" & nbligne).Value
    balise = balise + nbligne + 1
Next

Maintenant j'ai un message d'erreur dans la boucle suivante, qui me dit que la variable est non définie.

' supprime ligne si #N/A
For i = der_ligne To 1 Step -1
    If Application.IsNA(Cells(i, 2).Value) Then
        Range(Rows(i), Rows(i)).Delete
    End If
Next

Est-ce lié au fait que je me retrouve en bas de la liste ?

Non, rien à voir avec le fait que tu sois en dernière ligne, simplement comment est défini der_ligne ?

Maintenant, je ne comprends pas du tout du tout ce que tu veux faire en remodifiant la proposition de sub maj !!! d'autant que oui ta demande était claire

APetit a écrit :

Mon objectif est de déplacer ces onglets dans des fichiers séparés

Merci pour tes réponses, je vais tester à partir de lundi quand je serai de retour au travail. Par rapport à ta dernière remarque, ma demande était de modifier la macro existante pour qu'elle aille chercher les infos ailleurs. C'est pour cela que j'essaye d'intégrer dedans ce que tu m'as donné.

APetit a écrit :

Par rapport à ta dernière remarque, ma demande était de modifier la macro existante pour qu'elle aille chercher les infos ailleurs.

et c'est bien ce que j'ai fait il me semble ... les informations de ta macro maj() viennent maintenant des fichiers et non plus des onglets

Bonjour,

Je viens de revérifier, et c'est une nouvelle macro dans le fichier que tu m'a fourni. Pas une modification de l'existante comme je l'espérais. Vu que ce n'est pas moi qui l'avait rédigé à la base il y a peut être des choses qui ont leur utilité dedans.

Quoi qu'il en soit, j'ai appliqué le format date dans tous les fichiers source, et modifié la macro avec la ligne que tu m'a donné pour ne pas finir en bas du tableau. Le comportement est bon maintenant.

Je vois quand même le même nom de macro que j'ai repris et très nettement simplifiée : 32 lignes au lieu de 91.

Oui il y a peut-être d'autres fonctionnalités comme la suppression de lignes avec #N/A mais il faut corriger à la source le problème.

Si tu as des soucis, je reprendrais

N'oublie pas de clore le fil de discussion en cliquant sur

Ah oui ta version est plus courte et c'est une bonne chose pour faciliter la lecture. Mais vu que je ne comprends pas tout ce que l'originale faisait j'avais peur de perdre des choses. Pour les #N/A, ce n'est pas moi qui génère les fichiers source donc je n'ai pas la main pour les éradiquer à la racine.

Par contre, je suis en train de mettre en place cette macro sur mes vrais fichiers, et après l'avoir fait tourner, elle ne va pas chercher dans tous les onglets des fichiers source. C'est problématique, je suis en train de voir si je peux modifier moi même (ajout d'une boucle dans la boucle ?). Je reviens si je n'y arrive pas.

ok, désolé, je vais modifier pour explorer tous les onglets, en effet c'est une erreur

Voici, n'hésite pas si tu as un soucis

Option Explicit

    Dim wbk1 As Workbook, wbk2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim rng1 As Range, rng2 As Range

    Dim chemin$, monFichier$, onglet$

Sub maj()

    chemin = ThisWorkbook.Path & "\"

    Set wbk1 = ThisWorkbook
    Set ws1 = ActiveSheet
    ws1.Cells(1).CurrentRegion.Offset(1, 0).ClearContents
    monFichier = Dir(chemin & "*.xlsx")

    Do While monFichier <> ""
        Set wbk2 = Workbooks.Open(chemin & monFichier)
        For Each ws2 In wbk2.Worksheets
            Set rng2 = ws2.Cells(1).CurrentRegion
            rng2.Offset(1).Resize(rng2.Rows.Count - 1, rng2.Columns.Count).Copy
            Set rng1 = ws1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
            rng1.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        Next
        Application.CutCopyMode = False
        wbk2.Close False
        monFichier = Dir
    Loop

    ws1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select

End Sub

Nickel, cette fois les onglets sont tous lus

J'ai encore un problème avec mes totaux sur mes fichiers de prod, je suis en train de regarder d'où ça vient.

J'ai trouvé pourquoi je ne retombais pas sur les mêmes totaux avec la mise en place de cette nouvelle macro. Lorsqu'un onglet est filtré, elle ne va lire que ce qui est affiché. J'ai fait le test avec l'ancienne et elle n'a pas ce comportement car elle sort toutes les données.

Du coup je vais vraiment avoir besoin de reprendre toutes les fonctions de l'ancienne macro pour éviter ce genre de surprise. Penses-tu pouvoir me faire ça ? (désolé j'ai vraiment l'impression d'abuser de ta gentillesse et ton temps )

Essaie en ajoutant

If ws2.AutoFilterMode Then ws2.ShowAllData

edit : correction ci-après

Merci. Par contre là ça bloque dès le premier fichier avec la nouvelle ligne sur ws2.ShowAllData.

exact et vraiment désolé

vu ici https://stackoverflow.com/questions/18226045/showalldata-method-of-worksheet-class-failed, je ne dois pas être le seul à m'être fait prendre au piège ... l manquait AutoFilter

If ws2.AutoFilterMode Then ws2.AutoFilter.ShowAllData

Option Explicit

    Dim wbk1 As Workbook, wbk2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim rng1 As Range, rng2 As Range

    Dim chemin$, monFichier$, onglet$

Sub maj()

    chemin = ThisWorkbook.Path & "\"

    Set wbk1 = ThisWorkbook
    Set ws1 = ActiveSheet
    ws1.Cells(1).CurrentRegion.Offset(1, 0).ClearContents
    monFichier = Dir(chemin & "*.xlsx")

    Do While monFichier <> ""
        Set wbk2 = Workbooks.Open(chemin & monFichier)
        For Each ws2 In wbk2.Worksheets
            If ws2.AutoFilterMode Then ws2.AutoFilter.ShowAllData
            Set rng2 = ws2.Cells(1).CurrentRegion
            rng2.Offset(1).Resize(rng2.Rows.Count - 1, rng2.Columns.Count).Copy
            Set rng1 = ws1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
            rng1.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        Next
        Application.CutCopyMode = False
        wbk2.Close False
        monFichier = Dir
    Loop

    ws1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select

End Sub

Y a pas à être désolé, vu le gros service que tu me rends.

Je viens de tester avec un onglet filtré, cela n'influe pas sur les données récoltées. Donc c'est top ! Mes techniciens vont pouvoir remplir leurs suivis de leur côté et moi récupérer les données pour mesurer la progression.

Encore merci pour le coup de main

Bonjour, je reviens sur ce fil pour une question sur l'évolution de cette macro. Lorsqu'elle est exécutée, mes 17 fichiers source sont ouverts un par un pour récupérer les données, cela prend pas mal de ressources sur le PC.

Depuis quelques jours Excel s'arrête subitement avant la fin d’exécution de la macro car je pense qu'il y a un cache qui doit saturer et faire planter Excel. Il y a environ 22 000 lignes à traiter, peut-être que c'est trop. Auriez-vous une solution pour éviter cela ?

Je remet le code de la macro ci-dessous :

Option Explicit

Dim wbk1 As Workbook, wbk2 As Workbook

Dim ws1 As Worksheet, ws2 As Worksheet

Dim rng1 As Range, rng2 As Range

Dim chemin$, monFichier$, onglet$

Sub maj()

Sheets("Synthèse").Select

Range("A1").Select

chemin = ThisWorkbook.Path & "\"

Set wbk1 = ThisWorkbook

Set ws1 = ActiveSheet

ws1.Cells(1).CurrentRegion.Offset(1, 0).ClearContents

monFichier = Dir(chemin & "Suivi_Reception-CR5_N076*.xlsx")

Do While monFichier <> ""

Set wbk2 = Workbooks.Open(chemin & monFichier)

For Each ws2 In wbk2.Worksheets

If ws2.AutoFilterMode Then ws2.AutoFilter.ShowAllData

Set rng2 = ws2.Cells(1).CurrentRegion

rng2.Offset(1).Resize(rng2.Rows.Count - 1, rng2.Columns.Count).Copy

Set rng1 = ws1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)

rng1.PasteSpecial Paste:=xlPasteValuesAndNumberFormats

Next

Application.CutCopyMode = False

wbk2.Close False

monFichier = Dir

Loop

ws1.Cells(2, 1).Select

End Sub