Assembler plusieurs fichiers Excel dans un fichier / seul classeur

Houraaa ! Enfin !

C'est fou ce qu'on peut se compliquer la vie parfois...

Je suis vraiment content et ça veut dire que sur windows, le code aurait marché du premier coup .

Edit : Oui, c'est possible :

Sub Assembler()

rep = thisworkbook.path & application.pathseparator 'pour Ergotamine :)

fichier = dir(rep)
while fichier <> ""
    if fichier like "*.xlsx" and fichier <> thisworkbook.name then 'on le fait quand même mais après
        set wb = workbooks.open(rep & fichier)
        with wb.sheets(1).usedrange
            t = .offset(1,0).resize(.rows.count - 1, .columns.count)
        end with
        with thisworkbook.sheets(1)
            if .cells(1,1) = "" then .rows(1).value = wb.sheets(1).rows(1).value
            nvl = .cells(.rows.count, 1).end(xlup).row + 1
            .cells(nvl, 1).resize(ubound(t), ubound(t,2)) = t
        end with
        wb.close true
    end if
    fichier = dir
wend

thisworkbook.save

end sub

hey hey oui encore merci je ne sais pas si vous vous rendez compte le temps gagner pour assembler 50 fichiers que je faisais à la main d'habitude

Est-ce que vous pensez qu'on peut "améliorer" le code sans à devoir à remplir le "/exempleforum/" ? Idéalement j'aimerai mettre le fichier assembler.xlsm dans le répertoire avec tous mes fichiers et juste à exécuter la macro et op

Aussi dans mes fichiers sources, j'ai des lignes sans DATA en colonne B C D E... est-ce qu'on peut faire en sorte d'exclure ces DATA en colonne A ne soit pas copier dans mon fichier d'assemblage ? En gros vide en colonne B alors on ne copie pas le mot dans le fichier d'assemblage.

capture d e cran 2021 01 24 a 22 18 46

yes ça marche dans le ficher dans le même répertoire !

@3GB : Pourtant celon cet article c'est censé marché https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/macid-function étant donné qu'on indique que l'on cherche des fichier XLS5 et qu'il y en a bien dans le dossier ...

Je serais curieux de savoir ce qu'aurai donné

rep = thisworkbook.path & application.pathseparator

fichier = dir(rep, MacID("XLS5"))

Mais félicitations à vous tous (3GB, jnce84 et mdo100) pour avoir transpiré sur ce problème !

Oui, je me rends bien compte, 50 fichiers à la main, c'est pas marrant et on risque de faire des erreurs en plus...

Oui, j'ai déjà répondu pour le fichier Assemblage. Tu peux très bien le mettre avec les autres. Voici un nouvel essai :

Sub Assembler()

dim t()

rep = thisworkbook.path & application.pathseparator 'pour Ergotamine :)

fichier = dir(rep)
while fichier <> ""
    if fichier like "*.xlsx" and fichier <> thisworkbook.name then 'on le fait quand même mais après
        set wb = workbooks.open(rep & fichier)
        with wb.sheets(1).usedrange
            redim t(1 to .rows.count - 1, 1 to .columns.count): n = 0
            for i = 2 to .rows.count
                if .cells(i, 2) <> "" then
                    n = n + 1
                    for k = 1 to .columns.count
                        t(n, k) = .cells(i, k).value
                    next k
                end if
            next i
        end with
        with thisworkbook.sheets(1)
            if .cells(1,1) = "" then .rows(1).value = wb.sheets(1).rows(1).value
            nvl = .cells(.rows.count, 1).end(xlup).row + 1
            .cells(nvl, 1).resize(n, ubound(t,2)) = t
        end with
        wb.close true
    end if
    fichier = dir
wend

thisworkbook.save

end sub

Cdlt,

Ergotamine avec ton code j'ai une erreur d'execution pour ta curiosité ;)

@Ergotamine, oui, c'est étrange. J'ai un Mac mais je l'ai à moitié cassé et il marche au ralenti maintenant. J'ai presque envie de le sortir pour faire des essais ! Excel est incontournable, c'est pas possible qu'on ne puisse pas chercher les fichiers .xlsx directement.

Cdlt,

Avec tous les fichiers (sources et macro) dans le même répertoire ?

Je comprend pas à quoi sert MacID alors ... Incompréhensible

All good @3GB les DATA sans DATA en colonne B etc etc sont bien supprimés de la liste ! Bref tout est OKKKKKK maintenant. Encore un ENORME merci à résolu cela en quelques heures ! Et merci aussi @mdo100

@Ergotamine oui tout dans le même répertoire

C'est super !

Et n'oublie de prévenir les membres des autres forums pour leur éviter de s'arracher les cheveux à cause des fonctions Dir et MacID .

Bonne continuation,

C'est déjà fait ;) Belle soirée à tous

Bonjour tout le monde,
Voici un code qui permet de faire ce que je voulais mais qui n'ouvre pas les fichiers sources un par un si vous voulez voir :)

Sub Assembler()
Dim chemin$, fichier$, feuille$, ncol%, lig&, form$, h&
chemin = ThisWorkbook.Path & Application.PathSeparator 'dossier à adapter
fichier = Dir(chemin) '1er fichier du dossier
feuille = "Keywords" 'nom des feuilles à copier, à adapter
ncol = 15 'nombre de colonnes, à adapter
lig = 2 '1ère ligne de restitution, à adapter
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Feuil1 'CodeName à adapter
    .UsedRange.EntireRow.Offset(1).Delete 'RAZ
    While fichier <> ""
        If fichier Like "*.xlsx" Then
            form = "'" & chemin & "[" & fichier & "]" & feuille & "'!"
            h = 0
            On Error Resume Next
            h = ExecuteExcel4Macro("MATCH(""zzz""," & form & "C1)") 'calcul sur colonne 1
            On Error GoTo 0
            If h > 1 Then
                With .Cells(lig, 1).Resize(h - 1, ncol)
                    .FormulaArray = "=" & form & "R2C1:R" & h & "C" & ncol 'formule de liaison matricielle
                    .Value = .Value 'supprime la formule
                    .Replace 0, "", xlWhole 'supprime les zéros
                End With
                lig = lig + h - 1
            End If
        End If
        fichier = Dir 'fichier suivant
    Wend
    With .UsedRange: End With 'actualise les barres de défilement
End With
End Sub

Pour info le code est là par rapport à ma demande ! Sacrément fort ce job75 sur excel-download :)

Sub Assembler()
Dim chemin$, fichier$, feuille$, ncol%, lig&, form$, h&
chemin = ThisWorkbook.Path & Application.PathSeparator 'dossier à adapter
fichier = Dir(chemin) '1er fichier du dossier
feuille = "Keywords" 'nom des feuilles à copier, à adapter
ncol = 15 'nombre de colonnes, à adapter
lig = 2 '1ère ligne de restitution, à adapter
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Feuil1 'CodeName à adapter
    .UsedRange.EntireRow.Offset(1).Delete 'RAZ
    While fichier <> ""
        If fichier Like "*.xlsx" Then
            form = "'" & chemin & "[" & fichier & "]" & feuille & "'!"
            h = 0
            On Error Resume Next
            h = ExecuteExcel4Macro("MATCH(""zzz""," & form & "C1)") 'calcul sur colonne 1
            On Error GoTo 0
            If h > 1 Then
                With .Cells(lig, 1).Resize(h - 1, ncol)
                    .FormulaArray = "=" & form & "R2C1:R" & h & "C" & ncol 'formule de liaison matricielle
                    .Value = .Value 'supprime la formule
                End With
                lig = lig + h - 1
            End If
        End If
        fichier = Dir 'fichier suivant
    Wend
    With .UsedRange
        .Replace 0, "", xlWhole 'supprime les zéros
        .RemoveDuplicates 1, Header:=xlYes 'supprime les doublons en colonne A
    End With
    With .UsedRange
        .Columns(ncol + 1) = "=1/SIGN(COUNTA(RC2:RC[-1]))" 'NBVAL
        .Columns(ncol + 1) = .Columns(ncol + 1).Value 'supprime les formules
        .EntireRow.Sort .Columns(ncol + 1), xlAscending, Header:=xlYes 'tri pour regrouper et accélérer
        On Error Resume Next 'si aucune SpecialCell
        .Columns(ncol + 1).SpecialCells(xlCellTypeConstants, 16).EntireRow.Delete 'supprime les lignes
        .Columns(ncol + 1) = ""
    End With
    With .UsedRange: End With 'actualise les barres de défilement
End With
End Sub
Rechercher des sujets similaires à "assembler fichiers fichier seul classeur"