Macro: Fichier de Synthese, help !!

[lisette59]

Bonjour a tous!

J ai vraiment besoin de votre aide, si quelqu´un arrivez a me répondre..!

J ai plusieurs fichiers (tous dans le meme répertoire) avec des noms differents mais un onglet qui est identique dans tous ("Projet (EUR)" avec exactement la meme structure).

Je souhaiterai faire un fichier de synthese qui me prendrait certaines cellules de l onglet commun a tous (ex: G6, G7, J6, J8...) dans chaque fichier et qui me les restitueraient en ligne, les uns en dessous des autres.

(en fait chaque fichier correspond a un projet, et le but serait d avoir une feuille recap avec les projets les uns en desous des autres).

Je ne sais pas si je suis claire?

Merci d avance pour vos reponses!

 

[KenDev]

Re : Macro: Fichier de Synthese, help !!

Bonjour Lisette,

Je te joint un zip contenant, un classeur (celui qui doit faire la synthèse) et un sous dossier avec deux classeurs contenant des données. Tu peux le dézipper n'importe ou et faire un test. Ensuite il faudra adapter le code à ton cas particulier. Les lignes à adapter ont un commentaire. Cordialement

KD

Option Explicit

Sub Synthese()
Dim vChemin As String
Dim vClasseur() As String
Dim nb As Integer, i As Integer
Dim oWb1 As Workbook, oWbW As Workbook
Dim oWs1 As Worksheet, oWsS As Worksheet
Dim vLine As Long

    vChemin = ThisWorkbook.Path & "\MonDossier" 'remplacer par le chemin vers le dossier contenant les classeurs, ex : vChemin = "C:\Documents and Settings\Nom\Excel\forum"
    
    nb = 1
    ReDim vClasseur(1 To nb)
    vClasseur(1) = Dir(vChemin & "\" & "*.xls*")
    If vClasseur(1) = "" Then Exit Sub
    
    Do While vClasseur(nb) <> ""
        nb = nb + 1
        ReDim Preserve vClasseur(1 To nb)
        vClasseur(nb) = Dir
    Loop
    
    nb = nb - 1
    ReDim Preserve vClasseur(1 To nb)
    Set oWb1 = ThisWorkbook
    Set oWs1 = ThisWorkbook.Worksheets("Synth") 'remplacer par le nom de la feuille recevant les données
    vLine = oWs1.Cells(Rows.Count, 2).End(xlUp).Row + 1 'remplacer 2 par le n° d'une colonne non vide du tableau qui recoit les données
    
    For i = 1 To nb
        Workbooks.Open vChemin & "\" & vClasseur(i)
        Set oWbW = Workbooks(vClasseur(i))
        Set oWsS = oWbW.Worksheets("Projet_Eur") 'remplacer par le nom de l'onglet commun
        'bloc à adapter selon les cellules à chercher
        oWs1.Cells(vLine, 1) = oWsS.Cells(6, 7) 'copie G6 en colonne 1
        oWs1.Cells(vLine, 2) = oWsS.Cells(7, 7) 'copie G7 en colonne 2
        oWs1.Cells(vLine, 3) = oWsS.Cells(6, 10) 'copie J6 en colonne 3
        oWs1.Cells(vLine, 4) = oWsS.Cells(8, 10) 'copie J8 en colonne 4
        Set oWsS = Nothing
        oWbW.Close
        Set oWbW = Nothing
        vLine = vLine + 1
    Next i
    
End Sub

Edit : ajouter juste avant la dernière ligne End Sub:
Set oWs1 = Nothing
Set oWb1 = Nothing