Copy/Paste des cellules de différents fichiers pour en faire une synthèse

Le 30/04/2020 à 11:50

Bonjour,

Je vous envoi ce post car mon niveau de compréhension en VBA est insuffisant.

Je voudrais au travers d'une macro (que j'ai démarré) avoir un fichier de consolidation.

Je dois pour cela, prendre les informations dans plusieurs fichiers identiques (mais avec une numérotation différentes) et en faire une synthèse (suivi).

Je vous joins dans le post les fichiers FEP (Fiche Evolution Produit) et le fichier de synthèse.

Fichier FEP (FEP_DPE_EBEN_279) : dans ces fichiers on récupère les informations à copier

Fichier (Evolution FEP) : dans ce fichier, on vient coller les informations

--> J'ai un début de code mais je n'arrive pas à coller les informations sur une ligne en dessous de l'autre.

Option Explicit

'Declaration de variable

Dim NomClasseur As String

Dim DerLigne As Integer

Dim DerLigneTable As Integer

'Procédure permettant la consolidation de pluseiurs classeurs

Sub Consolider()

'Etape nº1 : Création des en-têtes

'On reinitialise le fichier synthèse à chaque démarrage

Columns("A:AA").Clear

Range("A10").Value = "PRG"

Range("B10").Value = "SERVICE"

Range("C10").Value = "NºFEP"

Range("D10").Value = "DATE"

Range("E10").Value = "RESPONSABLE"

Range("F10").Value = "MP"

Range("G10").Value = "DESIGNATION"

Range("H10").Value = "REFERENCE"

Range("I10").Value = "INTITULE"

Range("J10").Value = "BEP"

Range("K10").Value = "BEM"

Range("L10").Value = "MTC"

Range("M10").Value = "QP"

Range("N10").Value = "QDP"

Range("O10").Value = "MDC"

Range("P10").Value = "LOP"

Range("Q10").Value = "HA"

Range("R10").Value = "PU"

Range("S10").Value = "INDUS"

Range("T10").Value = "MANUF"

Range("U10").Value = "DOM"

Range("V10").Value = "DATE DE CREATION"

Range("W10").Value = "RESP BE"

Range("X10").Value = "RESP CPPP"

Range("Y10").Value = "DELAI DE REPONSE"

Range("Z10").Value = "ACCORD LANCEMENT"

Range("A10:I10").Interior.Color = RGB(255, 204, 153) 'Couleur de remplissage

Range("J10:U10").Interior.Color = RGB(0, 0, 0) 'Couleur de remplissage

Range("V10:Z10").Interior.Color = RGB(255, 204, 153) 'Couleur de remplissage

Range("A10:I10").Font.Color = vbBlack 'Couleur de police

Range("J10:U10").Font.Color = vbWhite 'Couleur de police

Range("V10:Z10").Font.Color = vbBlack 'Couleur de police

'Etape nº 2: Parcourir tous les fichiers du dossier prédéfini

ChDir "C:\Users\pio.rodriguez\Desktop\FEP"

'on cherche le premier classeur dans un dossier

NomClasseur = Dir("C:\Users\pio.rodriguez\Desktop\FEP\*.xlsm")

'on boucle pour chercher tous les classeurs

While Len(NomClasseur) > 0

Application.DisplayAlerts = False 'Desactive les boites de dialogue Excel

Application.ScreenUpdating = False

Workbooks.Open NomClasseur 'Ouverture du classeur

Range("K11").Copy Workbooks("EVOLUTION FEP.xlsm").Worksheets("SUIVI FEP").Range("B11") 'Code Projet

Range("K9").Copy 'Service

Range("AI9").Copy 'Nº FEPP

Range("Q9").Copy 'DATE

Range("C9").Copy 'Responsable

Range("C11").Copy 'MP

Range("F10").Copy 'DESIGNATION

Range("AG13").Copy 'REFERENCE

Range("T16").Copy 'INTITULE

Range("BH12").Copy 'BEP

Range("BH17").Copy 'BEM

Range("BH24").Copy 'MTC

Range("BH29").Copy 'QP

Range("BD35").Copy 'QDP

Range("BV35").Copy 'MDC

Range("BH40").Copy 'LOP

Range("BH49").Copy 'HA

Range("BT49").Copy 'Pilote Usine

Range("AY58").Copy 'Industrialisation

Range("BV58").Copy 'Manufacturing

Range("BN64").Copy 'DOM

Range("D68").Copy 'DATE DE CREATION

Range("M68").Copy 'Responsable BE

Range("AI68").Copy 'CPP

Range("AC9").Copy 'Delai de réponse

Range("BN64").Copy 'date LANCEMENT

Range("AX61").Copy 'ACCORD LANCEMENT

Workbooks("EVOLUTION FEP.xlsm").Activate 'on revient sur le classeur

DerLigne = ActiveSheet.UsedRange.Rows.Count + 1 'on recherche la dernière ligne vide de la feuille

Range("A10" & DerLigne).Select 'On se positionne sur la dernière ligne de la feuille

ActiveSheet.Paste 'Je colle les données

Workbooks(NomClasseur).Close 'Fermeture du classeur ouvert

NomClasseur = Dir 'On passe au prochain classeur

Wend

' DerLigneTable = ActiveSheet.UsedRange.Rows.Count + 1

Cells.EntireColumn.AutoFit 'On auto-ajuste les colonnes

Range("A1").Select

End Sub

Merci de votre aide et support.

Santé first!

Pío

PS: Je ne peux joindre les fichiers car trop volumineux

Le 30/04/2020 à 11:57

Bonjour Piororo, bonjour le forum,

Ni code, ni fichier, c'est presque l'Anarchie (Ni Dieu, ni Maître)...

Le 30/04/2020 à 12:10

Bonjour

Je suis allé trop vite sur le bouton d'evoi. J'ai rectifié.

Slts

Pío

Le 30/04/2020 à 12:27

Re,

à quoi servent toutes les ligne Copy si tu ne colles jamais :

Range("K9").Copy 'Service
Range("AI9").Copy 'Nº FEPP
Range("Q9").Copy 'DATE
Range("C9").Copy 'Responsable
Range("C11").Copy 'MP
Range("F10").Copy 'DESIGNATION
Range("AG13").Copy 'REFERENCE
Range("T16").Copy 'INTITULE
etc.
Le 30/04/2020 à 13:02

Re,

Si j'ai bien compris, ça donnerait ça. Tu adapteras les colonnes et le nom ou index de l'onglet source :

Sub Consolider()
Dim CD As Workbook 'Classeur Destination
Dim OD As Worksheet 'Onglet Destination
Dim CA As String 'Chemin d'Accès
Dim CS As Workbook 'Classeur Source
Dim OS As Worksheet 'Onglet Source
Dim F As String 'Fichier
Dim PLV As Integer 'Première Ligne Vide

Application.ScreenUpdating = False
Set CD = ThisWorkbook
Set OD = CD.Worksheets("SUIVI FEP") '(si j'ai bien compris)
CA = "C:\Users\pio.rodriguez\Desktop\FEP\"

'Etape nº1 : Création des en-têtes
'On reinitialise le fichier synthèse à chaque démarrage
OD.Columns("A:AA").Clear
OD.Range("A10").Value = "PRG"
OD.Range("B10").Value = "SERVICE"
OD.Range("C10").Value = "NºFEP"
OD.Range("D10").Value = "DATE"
OD.Range("E10").Value = "RESPONSABLE"
OD.Range("F10").Value = "MP"
OD.Range("G10").Value = "DESIGNATION"
OD.Range("H10").Value = "REFERENCE"
OD.Range("I10").Value = "INTITULE"
OD.Range("J10").Value = "BEP"
OD.Range("K10").Value = "BEM"
OD.Range("L10").Value = "MTC"
OD.Range("M10").Value = "QP"
OD.Range("N10").Value = "QDP"
OD.Range("O10").Value = "MDC"
OD.Range("P10").Value = "LOP"
OD.Range("Q10").Value = "HA"
OD.Range("R10").Value = "PU"
OD.Range("S10").Value = "INDUS"
OD.Range("T10").Value = "MANUF"
OD.Range("U10").Value = "DOM"
OD.Range("V10").Value = "DATE DE CREATION"
OD.Range("W10").Value = "RESP BE"
OD.Range("X10").Value = "RESP CPPP"
OD.Range("Y10").Value = "DELAI DE REPONSE"
OD.Range("Z10").Value = "ACCORD LANCEMENT"
OD.Range("A10:I10").Interior.Color = RGB(255, 204, 153) 'Couleur de remplissage
OD.Range("J10:U10").Interior.Color = RGB(0, 0, 0) 'Couleur de remplissage
OD.Range("V10:Z10").Interior.Color = RGB(255, 204, 153) 'Couleur de remplissage
OD.Range("A10:I10").Font.Color = vbBlack 'Couleur de police
OD.Range("J10:U10").Font.Color = vbWhite 'Couleur de police
OD.Range("V10:Z10").Font.Color = vbBlack 'Couleur de police

'on cherche le premier fichier dans un dossier
F = Dir(CA & "*.xlsm")
Do While F <> ""
    Set CS = Workbooks.Open(CA & F) 'définit le classeur source en l'ouvrant
    Set OS = CS.Worksheets(1) 'définit l'onglet source (à adapter, sans les fichiers je ne peux pas deviner)
    PLV = OD.Cells(Application.Rows.Count, "A").End(xlUp).Row + 1 'définit la première ligne vide PLV de la colonne A de l'onglet destination
    OS.Range("K11").Copy OD.Cells(PLV, "B") 'Code Projet (colonne à adapter)
    OS.Range("K9").Copy OD.Cells(PLV, "C") 'Service (colonne à adapter)
    OS.Range("AI9").Copy OD.Cells(PLV, "D") 'Nº FEPP (colonne à adapter)
    OS.Range("Q9").Copy OD.Cells(PLV, "E") 'DATE (colonne à adapter)
    OS.Range("C9").Copy OD.Cells(PLV, "F") 'Responsable (colonne à adapter)
    OS.Range("C11").Copy OD.Cells(PLV, "G") 'MP (colonne à adapter)
    OS.Range("F10").Copy OD.Cells(PLV, "H") 'DESIGNATION (colonne à adapter)
    OS.Range("AG13").Copy OD.Cells(PLV, "I") 'REFERENCE (colonne à adapter)
    OS.Range("T16").Copy OD.Cells(PLV, "J") 'INTITULE (colonne à adapter)
    OS.Range("BH12").Copy OD.Cells(PLV, "K") 'BEP (colonne à adapter)
    OS.Range("BH17").Copy OD.Cells(PLV, "L") 'BEM (colonne à adapter)
    OS.Range("BH24").Copy OD.Cells(PLV, "M") 'MTC (colonne à adapter)
    OS.Range("BH29").Copy OD.Cells(PLV, "N") 'QP (colonne à adapter)
    OS.Range("BD35").Copy OD.Cells(PLV, "O") 'QDP (colonne à adapter)
    OS.Range("BV35").Copy OD.Cells(PLV, "P") 'MDC (colonne à adapter)
    OS.Range("BH40").Copy OD.Cells(PLV, "Q") 'LOP (colonne à adapter)
    OS.Range("BH49").Copy OD.Cells(PLV, "R") 'HA (colonne à adapter)
    OS.Range("BT49").Copy OD.Cells(PLV, "S") 'Pilote Usine (colonne à adapter)
    OS.Range("AY58").Copy OD.Cells(PLV, "T") 'Industrialisation (colonne à adapter)
    OS.Range("BV58").Copy OD.Cells(PLV, "U") 'Manufacturing (colonne à adapter)
    OS.Range("BN64").Copy OD.Cells(PLV, "V") 'DOM (colonne à adapter)
    OS.Range("D68").Copy OD.Cells(PLV, "W") 'DATE DE CREATION (colonne à adapter)
    OS.Range("M68").Copy OD.Cells(PLV, "X") 'Responsable BE (colonne à adapter)
    OS.Range("AI68").Copy OD.Cells(PLV, "Y") 'CPP (colonne à adapter)
    OS.Range("AC9").Copy OD.Cells(PLV, "Z") 'Delai de réponse (colonne à adapter)
    OS.Range("BN64").Copy OD.Cells(PLV, "AA") 'date LANCEMENT (colonne à adapter)
    OS.Range("AX61").Copy OD.Cells(PLV, "AB") 'ACCORD LANCEMENT (colonne à adapter)
    CS.Close False 'Fermeture du classeur source sans enregistrer
    F = Dir 'On passe au prochain classeur
Loop
OD.Cells.EntireColumn.AutoFit 'On auto-ajuste les colonnes
OD.Range("A1").Select
Application.ScreenUpdating = True
End Sub
Le 30/04/2020 à 13:30

Bonjour,

Je ne sais pas pourquoi, mais le fichier fait 23Mb alors qu¡il n'y a quasiment aucune information.

Range("K9").Copy 'Service

Range("AI9").Copy 'Nº FEPP

Range("Q9").Copy 'DATE

Range("C9").Copy 'Responsable

Ce sont les inforamtions du fichiers FEP que je dois aller chercher et coller dans le fichier de synthèse.

SI tu me passe un mail, je peux t'envoyer les fichiers.

Slts

Pio

Le 30/04/2020 à 13:40

Re,

Je t'ai envoyé une proposition à adapter. L'as-tu ouverte ?

Le 30/04/2020 à 13:55

Bonjour

Oui, je l'ai vu. J'ai changé le lien vers le fichier FEP. J'ai remis en forme les colonnes, mais, rien ne s'affiche. Juste 2 barres au niveau du format d'une cellule.

Désolé. mais je suis encore plus perdu!

Slts

Pío

Le 30/04/2020 à 14:02

Re,

24 Mb pour un fichier ce n'est pas normal !... Je t'envoie mon adresse mail par mail perso. C'est vraiment pour essayer de te sortir de la panade car je n'aime pas faire ça...

Le 30/04/2020 à 14:38

Bonjour,

Vous ne pouvez pas vous imaginez à quelle point j'apprécie cette aide.

Slts

Rechercher des sujets similaires à "copy paste differents fichiers synthese"