Copier bout à bout plusieurs lignes

Bonjour à tous,

Etant novice en programmation, je vous sollicite pour la raison suivante :

Je dispose d'un répertoire contenant plusieurs classeurs .xlsx

Mon but est de copier bout à bout la première ligne de chaque classeur dans un classeur actif.

Pour le moment, j'ai bidouillé un bout de code qui me permet de copier chaque première ligne l'une en dessous de l'autre. Le seul soucis c'est que je n'arrive pas à les mettre bout à bout.

Quelqu'un pour m'aider s'il vous plait ? ou me passer un petit bout de code que j'adapterai

 
 Sub Compilation_Lignes()

Dim Fichier As String
Dim Chemin As String
Dim ClasseurSource As Workbook

Application.DisplayAlerts = False 'Evite les messages d'Excel
Application.EnableEvents = False 'Evite l'exécution éventuelle de macros liées aux fichiers ouverts

Chemin = "D:\Users\ighilahrizrya\Desktop\dossier\" 'Chemin du répertoire contenant les fichiers
Fichier = Dir(Chemin & "*.xlsx")

Do While Fichier <> ""
    Set ClasseurSource = Workbooks.Open(Chemin & Fichier)
    ClasseurSource.Worksheets("Feuil1").Select 'nom de la feuille source (commune à tous les fichiers sources)
    Range("B1:ZZ1").Copy

'    Range("A2").Activate
'    Range(Selection, Selection.End(xlDown)).Select 'selection de la zone à copier
'    Selection.Copy

    ThisWorkbook.Activate
    Sheets("Feuil1").Select
    Cells(65535, 1).End(xlUp)(2).Select 'recherche de la première ligne vide

    ActiveSheet.Paste
    ClasseurSource.Close
    Fichier = Dir
Loop

Application.EnableEvents = True
Application.DisplayAlerts = True

End Sub
 

Bonjour,

Le seul soucis c'est que je n'arrive pas à les mettre bout à bout.

que veux-tu dire ?

toutes les résultats sur la ligne 1 ?

tous le texte dans une seule cellule ?

Désolé pour le manque de clarté. Il s'agit de mettre des "groupes" de colonnes les uns à la suite des autres, sur la même ligne.

Dis autrement, cela fait référence à ta première proposition

Cdlt,

Bonjour,

Pour le principe, pas testé.

Cdlt.

Option Explicit

Sub Compilation_Lignes()
Dim wb As Workbook, wb2 As Workbook
Dim ws As Worksheet, ws2 As Worksheet
Dim Fichier As String
Dim Chemin As String
Dim Ligne As Long
Const RNG As String = "B1:ZZ1"

    With Application
        .DisplayAlerts = False
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Feuil1")

    Chemin = "D:\Users\ighilahrizrya\Desktop\dossier\"
    Fichier = Dir(Chemin & "*.xlsx")

    Do While Fichier <> ""
        Set wb2 = Workbooks.Open(Chemin & Fichier)
        Set ws2 = wb2.Worksheets("Feuil1")
        ws2.Range(RNG).Copy
        Ligne = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
        ws.Cells(Ligne, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats        
        wb2.Close savechanges:=False
        Application.CutCopyMode = False
        Fichier = Dir
    Loop

    Application.EnableEvents = True

End Sub

Bonjour Eric,

Tout d'abord merci d'avoir essayé.

Je viens de tester.

Pas de différences par rapport à mon code initial...

C'est bon ! c'est fait.

Merci Jean-Eric pour votre aide