Importer cellules de fichiers Excel dans un seul fichier

Bonjour,

Apres avoir cherche depuis plusieurs sur differents forums je sollicite votre aide.

je possede un dossier avec environ 300 fichiers tous sous format identique, avec 1 onglet qui contient 1 tableau. Si ca peut vous etre utile, l'onglet dans ces fichiers sources se nomme genralement "Field Check List". Je souhaite importer les cellules B90:CN90 de chacun de ces 300 fichiers dans un nouveau fichier synthese qui contiendra donc la ligne 90 de chacun de mes fichiers. Je veux que ces lignes soit copies les unes apres les autres dans mon fichier synthese.

Jai, grace aux forums, construit cette macro ci-dessous. Mon importation marche tres bien mais elle me copie seulement la valeur de chaque cellules des lignes 90, alors que je souhaite qu'elle copie en plus des valeurs :

• Le format de la ligne 90 : certaines cellules dans la ligne sont par exemples sur fond rouge et je veux garder cette couleur pour ces cellules.
• Les eventuels commentaires qui sont ajoutes a des cellules.

 Sub MergeAllWorkbooks()
    Dim SummarySheet As Worksheet
    Dim FolderPath As String
    Dim NRow As Long
    Dim FileName As String
    Dim WorkBk As Workbook
    Dim SourceRange As Range
    Dim DestRange As Range

    ' Create a new workbook and set a variable to the first sheet.
    Set SummarySheet = Workbooks.Add(xlWBATWorksheet).Worksheets(1)

    ' Modify this folder path to point to the files you want to use.
    FolderPath = "C:\Tho\Done\"

    ' NRow keeps track of where to insert new rows in the destination workbook.
    NRow = 2

   ' Call Dir the first time, pointing it to all Excel files in the folder path.
    FileName = Dir(FolderPath & "*.xl*")

    ' Loop until Dir returns an empty string.
    Do While FileName <> ""
        ' Open a workbook in the folder
        Set WorkBk = Workbooks.Open(FolderPath & FileName)

        ' Set the cell in column A to be the file name.
        SummarySheet.Range("A" & NRow).Value = FileName

        ' Set the source range to be B90 through CN90.
        ' Modify this range for your workbooks.
        ' It can span multiple rows.
        Set SourceRange = WorkBk.Worksheets(1).Range("B90:CN90")

        ' Set the destination range to start at column B and
        ' be the same size as the source range.
        Set DestRange = SummarySheet.Range("B" & NRow)
        Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _
        SourceRange.Columns.Count)

        ' Copy over the values from the source to the destination.
        DestRange.Value = SourceRange.Value

        ' Increase NRow so that we know where to copy data next.
        NRow = NRow + DestRange.Rows.Count

        ' Close the source workbook without saving changes.
        WorkBk.Close savechanges:=False

        ' Use Dir to get the next file name.
        FileName = Dir()
    Loop

    ' Call AutoFit on the destination sheet so that all
    ' data is readable.
    SummarySheet.Columns.AutoFit
End Sub

De plus si vous avez de l'idee, une petite option pourrait etre ajoutee a la macro, mais qui n'est pas indispensable : comme dit precedement chaque fichier source contient 1 onglet avec la ligne 90 a copier, mais certains (pas nombreux) contiennent 2 onglets, ou il faudrait donc copier les lignes 90 de ces 2 onglets.

Merci beaucoup de votre aide ! (desole pour le manque d'accents dans mon texte j'ai un clavier anglais).

Bonjour,

Essaie ceci :

Do While FileName <> ""
        Set WorkBk = Workbooks.Open(FolderPath & FileName)
        SummarySheet.Range("A" & NRow).Value = FileName
        Set SourceRange = WorkBk.Worksheets(1).Range("B90:CN90")
        Set DestRange = SummarySheet.Cells(NRow, 2)
        SourceRange.Copy Destination:=DestRange
        NRow = NRow + 1
        WorkBk.Close savechanges:=False
        FileName = Dir()
    Loop

Bonjour,

Super merci.

Cependant une fois votre code colle ca m'importe maintenant les cellules entieres avec leur formules, donc ca m'ecrit dans mon fichier synthese #REF de partout. Alors que je souhaiterai seulement importer les valeurs, leur format et leurs commentaires.

J'ai essaye de changer votre code mais je n'ai rien trouve de concluant...

De plus auriez-vous une idee pour coller aussi la ligne 90 de l'onglet 2 quand cet onglet 2 existe dans le fichier source ?

Cdt,

Thomas

Bonjour,

essaie ainsi :

Do While Filename <> ""
        Set WorkBk = Workbooks.Open(FolderPath & Filename)
        SummarySheet.Range("A" & NRow).Value = Filename
        Set SourceRange = WorkBk.Worksheets(1).Range("B90:CN90")
        Set destrange = SummarySheet.Cells(NRow, 2)
        SourceRange.Copy
        With destrange
            .PasteSpecial xlPasteValuesAndNumberFormats
            .PasteSpecial xlPasteFormats
            .PasteSpecial xlPasteColumnWidths
            .PasteSpecial xlPasteComments
        End With
        Application.CutCopyMode = 0
        NRow = NRow + 1
        WorkBk.Close savechanges:=False
        Filename = Dir()
    Loop

Super ca marche parfaitement merci beaucoup Jean-Eric ! Un enorme gain de temps.

Et auriez-vous une idee pour copier egalement les donnees du deuxieme onglet quand ce deuxieme onglet existe dans les fichiers sources ? (C'est a dire qu'a chaque fois qu'il y a un deuxieme onglet dans mon fichier source je souhaite que la ligne 90 de celui-ci soit copie dans mon fichier synthese, en dessous de la ligne 90 du premier onglet ).

Merci,

Thomas