XL pour MAC Fusionner plusieurs fichiers

[Velpri]

Bonjour à tous,

je souhaite fusionner 50 classeur d'une page, en une seule page sur un nouveau classeur, les 50 classeurs ont le mêmes nombre de colonnes seul les lignes varies, je n'ai rien de trouvé de vraiment pratique, à noté que je suis sous Excel Mac version 16,97 et du coup je crois bien que Power Query ne fonctionne pas sur cette version, à votre avis quelle pourrait être la solution?

 

[sylvanu]

Bonsoir Verpri,
Un essai en PJ qui marche sur PC. Sur MAC à tester.
Tous les fichiers de données doivent être dans le même dossier, ainsi que cette PJ.
Aucun autre fichier ne doit être présent dans ce dossier à par ceux lister ci dessus.

 

[job75]

Bonsoir à tous,

50 fichiers ce n'est pas beaucoup et le plus simple est de les ouvrir et copier un par un.

Téléchargez les fichiers joints dans le même dossier et exécutez cette macro :

Sub Consolider()
Dim chemin$, fichier$, F As Worksheet, lig&, n%
chemin = ThisWorkbook.Path & Application.PathSeparator
fichier = Dir(chemin) '1er fichier du dossier
Set F = ActiveSheet
lig = 1
Application.ScreenUpdating = False
F.Rows(lig & ":" & F.Rows.Count).Delete 'RAZ
While fichier <> ""
    If Right(fichier, 5) = ".xlsx" Then
        n = n + 1
        With Workbooks.Open(chemin & fichier).Sheets(1)
            With .Cells(1).CurrentRegion.EntireRow
                If n = 1 Then
                    .Copy F.Cells(lig, 1)
                    lig = lig + .Rows.Count
                Else
                    .Offset(1).Copy F.Cells(lig, 1)
                    lig = lig + .Rows.Count - 1
                End If
            End With
            .Parent.Close False
        End With
    End If
    fichier = Dir
Wend
F.Columns.AutoFit 'ajustement largeurs
End Sub

A+

 

[kiki29]

Salut,si curieux,à télécharger puis consulter/adapter à ton contexte : Liste Contributions PDF
y faire une recherche sur Fusion

 

[Velpri]

Bonsoir Verpri,
Un essai en PJ qui marche sur PC. Sur MAC à tester.
Tous les fichiers de données doivent être dans le même dossier, ainsi que cette PJ.
Aucun autre fichier ne doit être présent dans ce dossier à par ceux lister ci dessus.

Merci à sylvanu et job75, les deux codes fonctionnent parfaitement bien, kiki29 désolé mais j'ai pas compris

Pour continuer à faire évoluer ce classeur, pensez vous qu'il soit possible de créer une requête afin de trouver des mots clefs dans cette feuille, je sais que la fonction recherche va fonctionner, mais je cherche quelque chose de plus souple pour utilisation, dans mon exemple si je cherche "Range Rover" je souhaiterais que la ligne soit surligner afin de pouvoir la supprimer si besoin

​

​

 

[kiki29]

Salut, posts# 7,13,14,25,36,37,63,66,67,88,89,91,162,200,201,206 de liste contribution

 

[job75]

Bonjour Velpri, le forum,

Pour rechercher un texte on peut utiliser cette macro :

Sub Rechrche()
Dim texte, col%
texte = Application.InputBox("Texte clé :", "Recherche")
If texte = False Or texte = "" Then Exit Sub
Application.ScreenUpdating = False
Cells.Interior.ColorIndex = xlNone 'RAZ
With ActiveSheet.UsedRange
    For col = 1 To 56
        .AutoFilter col, "*" & texte & "*" 'filtre automatique
        .SpecialCells(xlCellTypeVisible).Interior.ColorIndex = 6 'jaune
        .AutoFilter 'ôte le filtre
    Next
    .Rows(1).Interior.ColorIndex = xlNone
End With
End Sub

A+

 

[job75]

Juste un complément.

Pour tester la macro du post #3 j'ai créé 50 fichiers identiques à "aix-en-provence copie.xlsx", la macro s'exécute chez moi en 16 secondes.

On peut gagner du temps en utilisant des formules de liaison, ceci s'exécute en 2,7 secondes :

Sub Consolider()
Dim chemin$, fichier$, feuil$, ncol%, F As Worksheet, lig&, n%, form$, derlig&
chemin = ThisWorkbook.Path & Application.PathSeparator
fichier = Dir(chemin) '1er fichier du dossier
feuil = "Export - Scrap.io"
ncol = 56 'nombre de colonnes
Set F = ActiveSheet
lig = 1
Application.ScreenUpdating = False
F.Rows(lig & ":" & F.Rows.Count).Delete 'RAZ
While fichier <> ""
    If Right(fichier, 5) = ".xlsx" Then
        n = n + 1
        form = "'" & chemin & "[" & fichier & "]" & feuil & "'!"
        derlig = ExecuteExcel4Macro("MATCH(""zzz""," & form & "C5)")
        If n = 1 Then
            With F.Cells(lig, 1).Resize(derlig, ncol)
                .FormulaArray = "=""""&" & form & "R1C1:R" & derlig & "C" & ncol 'formule matricielle
                .Value = .Value 'supprime la formule
            End With
            lig = lig + derlig
        Else
            With F.Cells(lig, 1).Resize(derlig - 1, ncol)
                .FormulaArray = "=""""&" & form & "R2C1:R" & derlig & "C" & ncol 'formule matricielle
                .Value = .Value 'supprime la formule
            End With
            lig = lig + derlig - 1
        End If
    End If
    fichier = Dir
Wend
F.Rows(1).Font.Bold = True 'gras
F.Columns.AutoFit 'ajustement largeurs
End Sub

Bien sûr les formats ne sont pas copiés.

 

[Velpri]

Merci job75, la macro qui va plus doucement me convient très bien, mais merci pour la formule 1.
La macro pour cherche du texte fonctionne partiellement, lorsque je rentre le mot recherché dans la fenêtre recherche, je clic sur ok, ça reste bloqué quelques secondes puis le message "erreur d’exécution 1004", je clic sur fin, et là les lignes avec le mot cherché apparaisse en jaune.
Si je clic sur déboguer j'ai la ligne " .AutoFilter col, "*" & texte & "*" 'filtre automatique" surligné en jaune.

En utilisant la macro proposé je me demande si il y'a possibilité d'ajouter une fonction qui supprimerai les lignes créer en jaune si toute fois je souhaite les conservées, et également cette macro, ou une autre aurait-elle la possibilité de trier les colonnes de A à O tel que pourrait le faire la fonction données, trier , trier par

 

[job75]

La macro du post #7 fonctionne bien si le tableau a 56 colonnes.

Si ce n'est pas le cas utilisez :

Sub Recherche()
Dim texte, col%
texte = Application.InputBox("Texte clé :", "Recherche")
If texte = False Or texte = "" Then Exit Sub
Application.ScreenUpdating = False
Cells.Interior.ColorIndex = xlNone 'RAZ
With ActiveSheet.UsedRange
    For col = 1 To .Columns.Count
        .AutoFilter col, "*" & texte & "*" 'filtre automatique
        .SpecialCells(xlCellTypeVisible).Interior.ColorIndex = 6 'jaune
        .AutoFilter 'ôte le filtre
    Next
    .Rows(1).Interior.ColorIndex = xlNone
End With
End Sub

 

[Velpri]

Merci job75, effectivement je n'avais pas vu " col 1To 56"

 

[job75]

Et pour supprimer les lignes trouvées (colorées en jaune), utilisez :

Sub Recherche()
Dim texte, P As Range, col%, n&, rep%
texte = Application.InputBox("Texte clé :", "Recherche")
If texte = False Or texte = "" Then Exit Sub
Application.ScreenUpdating = False
Cells.Interior.ColorIndex = xlNone 'RAZ
With ActiveSheet.UsedRange
    Set P = .Rows(1)
    For col = 1 To .Columns.Count
        .AutoFilter col, "*" & texte & "*" 'filtre automatique
        With .SpecialCells(xlCellTypeVisible)
            .Interior.ColorIndex = 6 'jaune
            Set P = Union(P, .Cells)
        End With
        .AutoFilter 'ôte le filtre
    Next
    .Rows(1).Interior.ColorIndex = xlNone
    n = Intersect(.Columns(1), P).Count
    Application.ScreenUpdating = True
    rep = MsgBox(n - 1 & " ligne" & IIf(n > 2, "s", "") & " trouvée" & IIf(n > 2, "s", "") & _
        IIf(n > 1, ", voulez-vous " & IIf(n > 2, "les", "la") & " supprimer ?", ""), IIf(n > 1, vbQuestion + vbYesNo, vbInformation))
    If rep = vbYes Then Intersect(.Offset(1), P).EntireRow.Delete 'suppression
End With
End Sub

 

[Velpri]

Je me suis mal exprimé job, désolé, je voulais savoir si il étais possible d’effacer la couleur jaune des cellules, en effet le filtre fonctionne parfaitement, mais à la lecture des données coloré parfois il faut conservé les cellules en jaune, pour ce faire j'utilise la fonction remplissage automatique, et je sélectionne "aucun remplissage"