XL 2019 Ouverture fichiers excel et copier des lignes

AKOLIAI

XLDnaute Nouveau
Bonjour à tous,
Je ne suis pas très a l'aise avec VBA
mon besoin est le suivant :
j'ai un dossier qui contient des fichiers nommés (1, 2, 3, 4,...N)
Dans un fichier Excel deja ouvert je souhaite faire une macro qui fait l'action suivante :
Ouvrir les fichiers de 1 à N (un par un) et de copier la ligne 1 de l'onglet 1 du fichier 1 dans la fichier excel deja ouvert
et refaire la meme chose mais le soucis c'est que ça ne doit pas écraser la ligne qui a été copiée

Merci, je reste dispo pour clarifier si besoin

Merci par avance de votre précieuse aide :)

Bn courage à vous
 

Hasco

XLDnaute Barbatruc
Repose en paix
Bonjour,

Vous avez excel 2019, faites le à partir de PowerQuery, inclus dans votre version.

Vous pourrez ne conserver que les premières lignes si vous voulez.
Commencez puis revenez avec vos difficultés et deux ou trois fichiers exemple anonymisés à importer.

cordialement
 

psgfun

XLDnaute Nouveau
Bonjour à tous,
Je ne suis pas très a l'aise avec VBA
mon besoin est le suivant :
j'ai un dossier qui contient des fichiers nommés (1, 2, 3, 4,...N)
Dans un fichier Excel deja ouvert je souhaite faire une macro qui fait l'action suivante :
Ouvrir les fichiers de 1 à N (un par un) et de copier la ligne 1 de l'onglet 1 du fichier 1 dans la fichier excel deja ouvert
et refaire la meme chose mais le soucis c'est que ça ne doit pas écraser la ligne qui a été copiée

Merci, je reste dispo pour clarifier si besoin

Merci par avance de votre précieuse aide :)

Bn courage à vous
Bonsoir.
Ci-joint 4 fichiers test (1-2-3-Z)
Les trois premiers sont source.
Le dernier est destination.
N'hésite pas à ouvrir la macro (macro1) en mode pas à pas pour voir son fonctionnement.
Les séquences sont à répéter en fonction du nombre de sources.
Au boulot.
 

Pièces jointes

  • Z.xlsx
    13.7 KB · Affichages: 14
  • 2.xlsx
    14.1 KB · Affichages: 8
  • 3.xlsx
    14.2 KB · Affichages: 7
  • 1.xlsx
    14.2 KB · Affichages: 7

job75

XLDnaute Barbatruc
Bonsoir AKOLIAI, le forum,

Téléchargez les fichiers joints dans le même dossier (le bureau).

La macro affectée au bouton :
VB:
Sub Recap()
Dim chemin$, fichier$, feuil$, lig&, nf$, form$, ncol As Variant, ncol1 As Variant
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
fichier = Dir(chemin & "*.xlsx") '1er fichier du dossier
feuil = "Feuil1" 'nom des feuilles à copier
lig = 1 '1ère ligne de destination, à adapter
Application.ScreenUpdating = False
With Sheets("Recap") 'à adapter
    .Rows(lig & ":" & .Rows.Count).ClearContents 'RAZ
    While fichier <> ""
        nf = Left(fichier, Len(fichier) - 5)
        If nf = CStr(Int(Val(nf))) Then
            form = "'" & chemin & "[" & fichier & "]" & feuil & "'!R1"
            ncol = ExecuteExcel4Macro("MATCH(""zzz""," & form & ")")
            ncol1 = ExecuteExcel4Macro("MATCH(9^99," & form & ")")
            If IsError(ncol) Then ncol = 1
            If IsError(ncol1) Then ncol1 = 1
            If ncol1 > ncol Then ncol = ncol1
            With Cells(lig, 1).Resize(, ncol)
                .FormulaArray = "=" & form & "C1:R1C" & ncol 'formule matricielle
                .Value = .Value 'supprime la formule
            End With
            lig = lig + 1
        End If
        fichier = Dir
    Wend
    .UsedRange.Replace 0, "", xlWhole 'supprime les valeurs zéro
End With
End Sub
Les cellules sources sont copiées par des formules de liaison, sans ouvrir les fichiers.

Bonne nuit.
 

Pièces jointes

  • Recap(1).xlsm
    18.3 KB · Affichages: 8
  • 1.xlsx
    8.5 KB · Affichages: 6
  • 2.xlsx
    8.5 KB · Affichages: 7
  • 3.xlsx
    8.5 KB · Affichages: 7
Dernière édition:

AKOLIAI

XLDnaute Nouveau
Bonsoir AKOLIAI, le forum,

Téléchargez les fichiers joints dans le même dossier (le bureau).

La macro affectée au bouton :
VB:
Sub Recap()
Dim chemin$, fichier$, feuil$, lig&, nf$, form$, ncol As Variant, ncol1 As Variant
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
fichier = Dir(chemin & "*.xlsx") '1er fichier du dossier
feuil = "Feuil1" 'nom des feuilles à copier
lig = 1 '1ère ligne de destination, à adapter
Application.ScreenUpdating = False
With Sheets("Recap") 'à adapter
    .Rows(lig & ":" & .Rows.Count).ClearContents 'RAZ
    While fichier <> ""
        nf = Left(fichier, Len(fichier) - 5)
        If nf = CStr(Int(Val(nf))) Then
            form = "'" & chemin & "[" & fichier & "]" & feuil & "'!R1"
            ncol = ExecuteExcel4Macro("MATCH(""zzz""," & form & ")")
            ncol1 = ExecuteExcel4Macro("MATCH(9^99," & form & ")")
            If IsError(ncol) Then ncol = 1
            If IsError(ncol1) Then ncol1 = 1
            If ncol1 > ncol Then ncol = ncol1
            With Cells(lig, 1).Resize(, ncol)
                .FormulaArray = "=" & form & "C1:R1C" & ncol 'formule matricielle
                .Value = .Value 'supprime la formule
            End With
            lig = lig + 1
        End If
        fichier = Dir
    Wend
    .UsedRange.Replace 0, "", xlWhole 'supprime les valeurs zéro
End With
End Sub
Les cellules sources sont copiées par des formules de liaison, sans ouvrir les fichiers.

Bonne nuit.
Bonjour Job75,
Ta réponse est parfaite,
Une autre question complexe,
la macro que tu me présente fait directement un copier de toute la ligne, et elle n'écrase pas les données, c'est parfait,
J'ai une seconde demande, c'est que je ne souhaite pas copier toute la ligne du fichier 1, 2 ou 3,
Je souhaite récupérer des valeur de 5 ou 6 cellules, qui sont dans le meme onglet,
Exemple je souhaite copier les valeur de la cellule (A1), (B1) et (F1) par exemple et les coller directement dans le fichier recap sur la meme ligne en A1 et B1 et C1 par exemple,

Est ce que c'est faisable ?

Merci
 

job75

XLDnaute Barbatruc
Bonjour AKOLIAI, le forum,
je souhaite copier les valeur de la cellule (A1), (B1) et (F1) par exemple et les coller directement dans le fichier recap
C'est plus simple, voyez ce fichier (2) et la macro :
VB:
Sub Recap()
Dim chemin$, fichier$, feuil$, col, ub%, lig&, nf$, form$, i As Byte
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
fichier = Dir(chemin & "*.xlsx") '1er fichier du dossier
feuil = "Feuil1" 'nom des feuilles à copier
col = Array(1, 2, 6) 'numéros des colonnes à copier (A B F)
ub = UBound(col)
lig = 1 '1ère ligne de destination, à adapter
Application.ScreenUpdating = False
With Sheets("Recap") 'à adapter
    .Rows(lig & ":" & .Rows.Count).ClearContents 'RAZ
    While fichier <> ""
        nf = Left(fichier, Len(fichier) - 5)
        If nf = CStr(Int(Val(nf))) Then
            form = "='" & chemin & "[" & fichier & "]" & feuil & "'!R1C"
            For i = 0 To ub
                With Cells(lig, i + 1)
                    .FormulaR1C1 = form & col(i) 'formule de liaison
                    .Value = .Value 'supprime la formule
                End With
            Next
            lig = lig + 1
        End If
        fichier = Dir
    Wend
    .UsedRange.Replace 0, "", xlWhole 'supprime les valeurs zéro
End With
End Sub
A+
 

Pièces jointes

  • Recap(2).xlsm
    18.9 KB · Affichages: 5
  • 1.xlsx
    8.5 KB · Affichages: 3
  • 2.xlsx
    8.5 KB · Affichages: 4
  • 3.xlsx
    8.5 KB · Affichages: 2

AKOLIAI

XLDnaute Nouveau
Bonjour AKOLIAI, le forum,

C'est plus simple, voyez ce fichier (2) et la macro :
VB:
Sub Recap()
Dim chemin$, fichier$, feuil$, col, ub%, lig&, nf$, form$, i As Byte
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
fichier = Dir(chemin & "*.xlsx") '1er fichier du dossier
feuil = "Feuil1" 'nom des feuilles à copier
col = Array(1, 2, 6) 'numéros des colonnes à copier (A B F)
ub = UBound(col)
lig = 1 '1ère ligne de destination, à adapter
Application.ScreenUpdating = False
With Sheets("Recap") 'à adapter
    .Rows(lig & ":" & .Rows.Count).ClearContents 'RAZ
    While fichier <> ""
        nf = Left(fichier, Len(fichier) - 5)
        If nf = CStr(Int(Val(nf))) Then
            form = "='" & chemin & "[" & fichier & "]" & feuil & "'!R1C"
            For i = 0 To ub
                With Cells(lig, i + 1)
                    .FormulaR1C1 = form & col(i) 'formule de liaison
                    .Value = .Value 'supprime la formule
                End With
            Next
            lig = lig + 1
        End If
        fichier = Dir
    Wend
    .UsedRange.Replace 0, "", xlWhole 'supprime les valeurs zéro
End With
End Sub
A+
Merci, mais est ce que ça fonction sur un grand nombre de fichiers qui sont dans le memes dossier par exemple, la macro va scruter tous les fichiers et elle récupere les infos sans ecraser les lignes ?
Merci par avance de votre précisuese aide
 

job75

XLDnaute Barbatruc
Je ne vois pas ce que vous voulez dire, le nombre de fichiers n'a pas d'importance.

Mais prenez ce fichier (3), la macro est plus rapide car les formules sont supprimées en bloc :
VB:
Sub Recap()
Dim chemin$, fichier$, feuil$, col, ub%, lig&, nf$, form$, i%
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
fichier = Dir(chemin & "*.xlsx") '1er fichier du dossier
feuil = "Feuil1" 'nom des feuilles à copier
col = Array(1, 2, 6) 'numéros des colonnes à copier (A B F)
ub = UBound(col)
lig = 1 '1ère ligne de destination, à adapter
Application.ScreenUpdating = False
With Sheets("Recap") 'à adapter
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    .Rows(lig & ":" & .Rows.Count).ClearContents 'RAZ
    While fichier <> ""
        nf = Left(fichier, Len(fichier) - 5)
        If nf = CStr(Int(Val(nf))) Then
            form = "='" & chemin & "[" & fichier & "]" & feuil & "'!R1C"
            For i = 0 To ub
                Cells(lig, i + 1) = form & col(i) 'formule de liaison
            Next
            lig = lig + 1
        End If
        fichier = Dir
    Wend
    .UsedRange = .UsedRange.Value 'supprime les formules
    .UsedRange.Replace 0, "", xlWhole 'supprime les valeurs zéro
End With
End Sub
 

Pièces jointes

  • Recap(3).xlsm
    17.8 KB · Affichages: 4

AKOLIAI

XLDnaute Nouveau
J'ai testé la dernière macro ave 500 fichiers sources : l'exécution se fait chez moi en 2,3 secondes.

Edit : en fait la macro du fichier (3) n'est pas plus rapide que celle du fichier (2).
Super,
J'ai une dernière demande à faire,
c'est avec la meme macro si vraiment je peux choisir les cellule a copier dans le fichier recap,
Exemple :
J'ai N fichier excel qui ont la meme structure qui sont dans le meme dossier,
Je veux prendre dans chaque fichier Excel la valeur de la cellule B2 de la feuille 1 et la cellule F3 de la feuille 2 et la cellule E9 de la feuille 3 par exemple et les copier sur une meme ligne par ordre dans je viens de citer ?
et cela se refait pour tout les fichier Excel,
ya moyen d'adapter ta dernière MACRO,

Merci pour ton aide,

Cordialement
 

job75

XLDnaute Barbatruc
Pas compliqué si l'on a bien compris comment construire les formules de liaison :
VB:
Sub Recap()
Dim chemin$, fichier$, cellule, ub%, lig&, nf$, form$, i%
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
fichier = Dir(chemin & "*.xlsx") '1er fichier du dossier
cellule = Array("Feuil1'!B2", "Feuil2'!F3", "Feuil3'!E9") 'feuilles et cellules à copier, attention aux apostrophes
ub = UBound(cellule)
lig = 1 '1ère ligne de destination, à adapter
Application.ScreenUpdating = False
With Sheets("Recap") 'à adapter
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    .Rows(lig & ":" & .Rows.Count).ClearContents 'RAZ
    While fichier <> ""
        nf = Left(fichier, Len(fichier) - 5)
        If nf = CStr(Int(Val(nf))) Then
            form = "='" & chemin & "[" & fichier & "]"
            For i = 0 To ub
                Cells(lig, i + 1) = form & cellule(i) 'formule de liaison
            Next
            lig = lig + 1
        End If
        fichier = Dir
    Wend
    .UsedRange = .UsedRange.Value 'supprime les formules
    .UsedRange.Replace 0, "", xlWhole 'supprime les valeurs zéro
End With
End Sub
 

Pièces jointes

  • Recap(4).xlsm
    19.1 KB · Affichages: 7
  • 1.xlsx
    10 KB · Affichages: 6
  • 2.xlsx
    10 KB · Affichages: 5

AKOLIAI

XLDnaute Nouveau
Pas compliqué si l'on a bien compris comment construire les formules de liaison :
VB:
Sub Recap()
Dim chemin$, fichier$, cellule, ub%, lig&, nf$, form$, i%
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
fichier = Dir(chemin & "*.xlsx") '1er fichier du dossier
cellule = Array("Feuil1'!B2", "Feuil2'!F3", "Feuil3'!E9") 'feuilles et cellules à copier, attention aux apostrophes
ub = UBound(cellule)
lig = 1 '1ère ligne de destination, à adapter
Application.ScreenUpdating = False
With Sheets("Recap") 'à adapter
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    .Rows(lig & ":" & .Rows.Count).ClearContents 'RAZ
    While fichier <> ""
        nf = Left(fichier, Len(fichier) - 5)
        If nf = CStr(Int(Val(nf))) Then
            form = "='" & chemin & "[" & fichier & "]"
            For i = 0 To ub
                Cells(lig, i + 1) = form & cellule(i) 'formule de liaison
            Next
            lig = lig + 1
        End If
        fichier = Dir
    Wend
    .UsedRange = .UsedRange.Value 'supprime les formules
    .UsedRange.Replace 0, "", xlWhole 'supprime les valeurs zéro
End With
End Sub
Job75
Merci pour ton aide,
ça marche,
mais je souhaiterais mettre autant de cellule dans
cellule = Array("Feuil1'!B2", "Feuil2'!F3", "Feuil3'!E9") mais à un moment donnée ça me bloque et je ne peux pas ajouter de cellule, est ce que dans VBA c'est limité ou non ? par exemple si je souhaite copier 39 cellules, est cela est faisable ?
Merci par avance de ton aide
 

job75

XLDnaute Barbatruc
Bonsoir AKOUAI,

Chez moi un Array avec les adresses de 39 cellules ne pose pas de problème.

Mais bien sûr il faut écrire l'instruction sur plusieurs lignes :
VB:
cellule = Array("Feuil1'!B2", "Feuil2'!F3", "Feuil3'!E9", _
                "Feuil1'!B2", "Feuil2'!F3", "Feuil3'!E9", _
                "Feuil1'!B2", "Feuil2'!F3", "Feuil3'!E9", _
                "Feuil1'!B2", "Feuil2'!F3", "Feuil3'!E9", _
                "Feuil1'!B2", "Feuil2'!F3", "Feuil3'!E9", _
                "Feuil1'!B2", "Feuil2'!F3", "Feuil3'!E9", _
                "Feuil1'!B2", "Feuil2'!F3", "Feuil3'!E9", _
                "Feuil1'!B2", "Feuil2'!F3", "Feuil3'!E9", _
                "Feuil1'!B2", "Feuil2'!F3", "Feuil3'!E9", _
                "Feuil1'!B2", "Feuil2'!F3", "Feuil3'!E9", _
                "Feuil1'!B2", "Feuil2'!F3", "Feuil3'!E9", _
                "Feuil1'!B2", "Feuil2'!F3", "Feuil3'!E9", _
                "Feuil1'!B2", "Feuil2'!F3", "Feuil3'!E9") 'feuilles et cellules à copier, attention aux apostrophes
A+
 

AKOLIAI

XLDnaute Nouveau
Bonsoir AKOUAI,

Chez moi un Array avec les adresses de 39 cellules ne pose pas de problème.

Mais bien sûr il faut écrire l'instruction sur plusieurs lignes :
VB:
cellule = Array("Feuil1'!B2", "Feuil2'!F3", "Feuil3'!E9", _
                "Feuil1'!B2", "Feuil2'!F3", "Feuil3'!E9", _
                "Feuil1'!B2", "Feuil2'!F3", "Feuil3'!E9", _
                "Feuil1'!B2", "Feuil2'!F3", "Feuil3'!E9", _
                "Feuil1'!B2", "Feuil2'!F3", "Feuil3'!E9", _
                "Feuil1'!B2", "Feuil2'!F3", "Feuil3'!E9", _
                "Feuil1'!B2", "Feuil2'!F3", "Feuil3'!E9", _
                "Feuil1'!B2", "Feuil2'!F3", "Feuil3'!E9", _
                "Feuil1'!B2", "Feuil2'!F3", "Feuil3'!E9", _
                "Feuil1'!B2", "Feuil2'!F3", "Feuil3'!E9", _
                "Feuil1'!B2", "Feuil2'!F3", "Feuil3'!E9", _
                "Feuil1'!B2", "Feuil2'!F3", "Feuil3'!E9", _
                "Feuil1'!B2", "Feuil2'!F3", "Feuil3'!E9") 'feuilles et cellules à copier, attention aux apostrophes
A+
Thank you so much
 

Discussions similaires

Réponses
36
Affichages
1 K
Réponses
2
Affichages
252

Statistiques des forums

Discussions
311 720
Messages
2 081 913
Membres
101 837
dernier inscrit
Ugo