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

J

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
 
Trier par date Trier par votes
job75

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
Vote positif 0 Vote négatif
J

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
 
Vote positif 0 Vote négatif
job75

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
Vote positif 0 Vote négatif
J

jnce84

XLDnaute Nouveau
job75 à dit:
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.
Cliquez pour agrandir...

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
 
Vote positif 0 Vote négatif
job75

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
Vote positif 0 Vote négatif
J

jnce84

XLDnaute Nouveau
job75 à dit:
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+
Cliquez pour agrandir...

Tout semble OK avec ton fichier (5) ! Merci ENORMEMENT !
 
Vote positif 0 Vote négatif
J

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
Vote positif 0 Vote négatif

Discussions similaires

vgendron
  • Question
Power Query [Resolu] Importer plusieurs fichiers excel provenant de dossiers différents sur sharepoint
Réponses
6
Affichages
1 K
Staple1600
Staple1600
F
  • Résolu(e)
Autres Mapper fichier XML dans Excel avec TLE
2
Réponses
21
Affichages
457
FS69
F
C
  • Question
XL 2021 Dupliquer un fichier selon une liste déroulante
Réponses
2
Affichages
208
catdog
C
V
  • Question
Microsoft 365 Resume de plusieurs fichier
Réponses
2
Affichages
316
Cousinhub
Cousinhub
I
  • Résolu(e)
Microsoft 365 Ouvrir un fichier Excel rapidement en VBA
3 4 5
Réponses
61
Affichages
3 K
iliess
I
F
  • Question
Microsoft 365 comment ouvrir en lecture/écriture un fichier EXCEL placé sous sharepoint
Réponses
2
Affichages
889
fibled
F
Chaton77
  • Résolu(e)
Microsoft 365 Vba : Transférer des données d'un tableau dans un autre fichier
Réponses
7
Affichages
404
Chaton77
Chaton77
L
  • Résolu(e)
XL 2016 Récupérer données de différents fichiers Excel et rappatrier dans 1 seul fichier
Réponses
5
Affichages
693
LAPIN-53
L
Z
  • Question
XL 2016 Macro pour copier plusieurs cellules vers un fichier :(
Réponses
3
Affichages
303
zendb
Z
T
  • Question
XL 2019 Ouvrir et modifier un fichier Excel dans un autre
Réponses
4
Affichages
378
Theca
T

Membres actuellement en ligne

7 membres et 69 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 096
Messages
2 116 184
Membres
112 679
dernier inscrit
Yupanki