Copie multi-fichier à partir d'une macro

[Yakusa]

Bonjours à tous et à toutes,

J'aurai encore une fois besoin de vos aides pour mettre en place une macro.
J'ai un fichier XL avec X onglets et dans chaque onglet il y X ligne.

L'onglet qui m'interesse s'appel "finance"
Je souhaiterai capturer les cellules E38:H49 et les cellules I38:I49 et les placer dans un autre fichiers qui s'appelera traitee.xls


Mes soucis :
1 - E38:H49 s'étale sur plusieurs colonnes dans le fichier source et je souhaiterai les mettre dans une et une seule cellule concactené lors de la copie.
2 - Etant donné qu'il y a plusieurs fichiers XL (environ 200) alors l'objectif de ma macro est donc d'ouvrir/fermer chacun des fichiers et de copier les données qui lui intéressent.
Après avoir copié, il collera dans les cellules C4:C16 et D4😀16 du fichier traitee.xls

Est ce que c'est faisable ?
En remerciant d'avance

 

[Yakusa]

Re : Copie multi-fichier à partir d'une macro

J'ai l'impression que mon énoncé n'est pas très claire, est ce le cas ?
Je souhaiterai mettre mes exemples en pièces jointes, mais apparemment je n'ai pas le droit....

 

[Temjeh]

Re : Copie multi-fichier à partir d'une macro

Bonjour à tous


Non c'est assez clair mais le code et les maneoeuvre sont complexe.

Ici je te joint un fichier qui fait une liste de tes classeurs ...ouvre ...copie ...referme.

Travail dessus et reviens pour des questions.



http://pages.videotron.com/temjeh/zip/uptdate_recap.zip

Instruction:
Dans un classeur faire une feuil "Liste" et une "Recap"
Appeler ces macros dans sous 2 boutons en feuille "Liste"

Private Sub Macro1()
Application.DisplayAlerts = False
Dim r
r = Range("A65000").End(xlUp).Row
Dim chemin
chemin = ActiveWorkbook.Path

    For i = 1 To r
    ChDir ActiveWorkbook.Path
    Sheets("Liste").Select
    If Range("A" & i).Value = "uptdate_recap.xls" Then GoTo suivant
    On Error GoTo suivant
    Workbooks.Open Filename:=ActiveWorkbook.Path & "\" & Range("A" & i).Value
    
        'ici change la plage ex: Range("A1:E37").Select
        Range("A1:" & [A1].SpecialCells(xlCellTypeLastCell).Address).Select
            Selection.Copy
                Windows("Uptdate_Recap" & ".xls").Activate
                    Sheets("Recap").Select
                        Range("A65000").End(xlUp).Offset(1, 0).Select
                        ActiveSheet.Paste
                Range("A65000").End(xlUp).Offset(1, 0).Select
            ActiveCell = "Changement de classeur"
        Selection.EntireRow.Select
                
    With Selection.Interior
        .ColorIndex = 3
            .Pattern = xlSolid
            Selection.Font.ColorIndex = 2
         Selection.Font.Bold = True
    End With
                
        Sheets("Liste").Select
            Windows(Range("A" & i) & "").Activate
                ActiveWindow.Close SaveChanges:=False
                    Range("A1").Select
                Sheets("Recap").Select
            Range("A1").Select
        Application.DisplayAlerts = True
suivant:

    Next i
    
End Sub

Private Sub Macro2()
Dim TheFileSearcher
TheFileSearcher = ActiveWorkbook.Path
Dim i As Integer
On Error Resume Next
Set TheFileSearcher = Application.FileSearch

        With TheFileSearcher
            .NewSearch
                .Filename = "*.xls*"
                    .LookIn = ActiveWorkbook.Path
                .SearchSubFolders = False
            .Execute msoSortByFileName, msoSortOrderAscending
    If .Execute > 0 Then
        With .FoundFiles
        
            For i = 1 To .Count
            If ThePath & Dir(.Item(i)) = "uptdate_recap.xls" Then GoTo suivant
                Cells(i, 1).Value = ThePath & Dir(.Item(i))
suivant:

            Next i
        End With
            Else
                MsgBox "Pas de Fichier trouvéé dans " & ThePath
    End If
    
        End With
    
Set TheFileSearcher = Nothing
'trie
Columns("A:A").Select
    Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("A1").Select
End Sub

A+

Temjeh