XL pour MAC Assembler plusieurs fichiers Excel dans un fichier / seul classeur

jnce84

XLDnaute Nouveau
Bonjour,

Je me permets de solliciter votre aide car je travaille sur des exportations de DATA via un site internet et pour chaque étude, j'extrais un fichier Excel. A la fin de mon étude, je me retrouve avec une vingtaine de fichiers que je dois ouvrir un par un pour pouvoir en constituer qu'un seul pour traiter ensuite mes DATA. Je perds un temps fou à ouvrir chaque fichier pour voir coller les datas dans un seul fichier / un seul classeur. Auriez-vous une solution pour par exemple sélectionner tous les fichiers dans mon dossier et faire un click droit "assembler" (oui je rêve mais ça serait tellement idéal )

Voici un exemple de 3 fichiers que je voudrais assembler en un seul (Fichier Assemblage)

Merci pour votre aide, ça me ferait gagner un temps fou pour chaque export.

Fichier assemblé
Source1
Source2
Source3
 

job75

XLDnaute Barbatruc
C'est pas possible ça, MAC c'est une vraie catastrophe, alors testez ce fichier (3 bis) avec :
VB:
Sub Assembler()
Dim chemin$, liste, feuille$, ncol%, lig&, n%, form$, h&
chemin = ThisWorkbook.Path & Application.PathSeparator 'dossier à adapter
liste = Array("Source1.xlsx", "Source2.xlsx", "Source3.xlsx") 'liste des fichiers, à adapter
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
    For n = 0 To UBound(liste)
        form = "'" & chemin & "[" & liste(n) & "]" & 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
    Next
    With .UsedRange: End With 'actualise les barres de défilement
End With
End Sub
 

Pièces jointes

  • Assemblage(3 bis).xlsm
    19.9 KB · Affichages: 2

jnce84

XLDnaute Nouveau
Pour info,
voici une solution proposée qui a fonctionné :)

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
 

job75

XLDnaute Barbatruc
D'après ce que je vois sur MAC Dir n'accepte pas le caractère générique *.

Alors testez ce fichier (4) avec :
VB:
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
Nota : la colonne A des fichiers sources doit contenir des textes.
 

Pièces jointes

  • Assemblage(4).xlsm
    18.3 KB · Affichages: 3
  • Source1.xlsx
    7.2 KB · Affichages: 3
  • Source2.xlsx
    7.4 KB · Affichages: 3
  • Source3.xlsx
    11.4 KB · Affichages: 3

jnce84

XLDnaute Nouveau
D'après ce que je vois sur MAC Dir n'accepte pas le caractère générique *.

Alors testez ce fichier (4) avec :
VB:
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
Nota : la colonne A des fichiers sources doit contenir des textes.

Effectivement les fichiers sources ne s'ouvrent pas ! c'est bien plus optimal.

@job75 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.

Voici le code qu'on m'avait donner pour faire cela mais si tu peux adapter ton code ça serait encore mieux vu qu'on ouvre pas les sources :)

Et tant que j'y suis... :D est-ce que tu penses qu'il serait possible de supprimer en même temps tous les doublons en colonne A lors de l'assemblage ? :)

Code:
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
 

job75

XLDnaute Barbatruc
Bonjour jnce84,

Testez ce fichier(5) et la macro :
VB:
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
A+
 

Pièces jointes

  • Assemblage(5).xlsm
    19.7 KB · Affichages: 4

jnce84

XLDnaute Nouveau
Bonjour jnce84,

Testez ce fichier(5) et la macro :
VB:
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
A+

Tout semble OK avec ton fichier (5) ! Merci ENORMEMENT !
 

jnce84

XLDnaute Nouveau
Bonsoir job75,
Je voudrais créer un nouveau fichier d'assemblage pour ces 3 sources ? Est-ce que tu pourrais adapter ton code ? ça m'avancerait énormément dans mon travail ! même principe à savoir assemblage et suppression des doublons lors de la génération :)

Merci d'avance !
Jonathan
 

Pièces jointes

  • Archive.zip
    54.5 KB · Affichages: 2

Discussions similaires

Statistiques des forums

Discussions
311 724
Messages
2 081 936
Membres
101 844
dernier inscrit
pktla