Extraires de plusieurs dossiers un tableau dans un fichier cible
Bonjour à tous et à toutes,
Je vais essayé d'être précis
J'ai un fichier cible ayant 3 onglets "00_ENG-RS-VPF-FRM-0XX_A_OIL EDU-CAB_DR3D_FTA_BDI.xlsm" dans lequel ce trouve le tableau cible sous l'onglet "OIL EDU" , celui-ci étant à la base classé dans un classeur nommé "EDU CAB TEST"
Dans un sous-classeur "DR EDU CAB", dont je ne vais avoir qu'uniquement plusieurs fichiers du mêmes type en .xlxm , mais avec des noms différents
Chaqu'un de ces fichiers en .xlsm contient lui aussi plusieurs onglets dont un onglet "OIL"
Le sous-classeur "DR EDU CAB", sera rangé dans le classeur "EDU CAB TEST"
Je cherche donc à copier, sans lignes vides, et ceci à partir de la ligne 8 de ces dossiers en .xlsm vers ce fichier cible "OIL EDU"
Voilà ou j'en suis :
Public Sub Macro_OIL_EDU()
'Macro OIL pour EDUs
Set moShS = Worksheets("OIL EDU")
'nom du dossier "00_ENG-RS-VPF-FRM-0XX_A_OIL EDU-CAB_DR3D_FTA_BDI.xlsm" classé sous "EDU CAB TEST"
'je vais copier dans ce fichier "OIL EDU" à partir de la ligne 8
miEcr = 39
' je vais avoir plus de 6000 lignes (autant prévoir beaucoup plus : 65000)
Copier "OIL", 8, 38
'il faudrait prendre tous les fichiers sources en .xlxm rangés dans le classeur "DR EDU CAB" et ceci à partir de la ligne 8
Set moShS = Nothing
End Sub
Private Sub Copier(psOnglet As String, piLigDeb As Integer, piLigFin As Integer)
Const L_COUL_BLEU As Long = 12611584
Const S_OUI As String = "OUI"
Dim oSh As Worksheet
Dim iLig As Integer
Set oSh = Worksheets(psOnglet)
Application.ScreenUpdating = False
For iLig = piLigDeb To piLigFin
If oSh.Range("Y" & iLig) = S_OUI Then
'ici je vais mettre ca
'Question N°
moShS.Range("A" & miEcr).Value = oSh.Range("A" & iLig).Value
'Type de DR
moShS.Range("B" & miEcr).Value = oSh.Range("B" & iLig).Value
'Date de DR
moShS.Range("C" & miEcr).Value = oSh.Range("C" & iLig).Value
'DR Statut
moShS.Range("D" & miEcr).Value = oSh.Range("D" & iLig).Value
'Projet
moShS.Range("E" & miEcr).Value = oSh.Range("E" & iLig).Value
'Titre
moShS.Range("F" & miEcr).Value = oSh.Range("F" & iLig).Value
'N° Mounting
moShS.Range("G" & miEcr).Value = oSh.Range("G" & iLig).Value
'EDU
moShS.Range("H" & miEcr).Value = oSh.Range("H" & iLig).Value
'Poste études
moShS.Range("I" & miEcr).Value = oSh.Range("I" & iLig).Value
'Évaluation des risques
moShS.Range("K" & miEcr).Value = oSh.Range("K" & iLig).Value
'Plan d'Action
moShS.Range("N" & miEcr).Value = oSh.Range("N" & iLig).Value
'Pilot Action
moShS.Range("R" & miEcr).Value = oSh.Range("R" & iLig).Value
'Criticity L - M - H
moShS.Range("S" & miEcr).Value = oSh.Range("S" & iLig).Value
'pour Quand
moShS.Range("T" & miEcr).Value = oSh.Range("T" & iLig).Value
'Pt Fermé le
moShS.Range("V" & miEcr).Value = oSh.Range("V" & iLig).Value
'Open Closed Warning
moShS.Range("W" & miEcr).Value = oSh.Range("X" & iLig).Value
'ligne suivante
miEcr = miEcr + 1
'si ligne de titre, ajouter encore une ligne
If moShS.Range("A" & miEcr).Interior.Color = L_COUL_BLEU Then
miEcr = miEcr + 1
End If
End If
Next iLig
Application.ScreenUpdating = True
Set oSh = Nothing
End SubJ'ai revu ma copie, et j'en suis là
Ca ne marche toujours pas et rien ne s'affiche dans mon tableau cible
Sub CreationSynthese()
'Range("A8") = "Colonne pour le Nom des fichiers source à écrire dans A et en ligne 8"
'Colonnes à copier du fichier source (OIL)
'Range("A8") = "Question N°" du fichier cible
'Range("B8") = "Type de DR" du fichier cible
'Range("C8") = "Date de DR" du fichier cible
'Range("D8") = "DR Statut" du fichier cible
'Range("E8") = "Projet" du fichier cible
'Range("F8") = "Titre" du fichier cible
'Range("G8") = "N° Mounting" du fichier cible
'Range("H8") = "EDU" du fichier cible
'Range("I8") = "Poste études" du fichier cible
'Range("K8") = "Évaluation des risques" du fichier cible
'Range("N8") = "Plan d'Action" du fichier cible
'Range("R8") = "Pilot Action" du fichier cible
'Range("S8") = "Criticity L - M - H" du fichier cible
'Range("T8") = "pour Quand" du fichier cible
'Range("V8") = "Pt Fermé le" du fichier cible
'Range("X8") = "Open Closed Warning" du fichier cible
'Range("Y8") = "OUI" du fichier cible, si cette case est "OUI" alors copier les lignes de ce tableau
'Adresse du Fichier source (C:\Users\brenaud\Desktop\EDU CAB TEST\DR EDU CAB)
'Nom des fichiers source (.xlxm)
'Nom de l'onglet source (OIL)
'Adresse du Fichier cible (C:\Users\brenaud\Desktop\EDU CAB TEST)
'Nom du fichier cible (00_ENG-RS-VPF-FRM-0XX_A_OIL EDU-CAB_DR3D_FTA_BDI.xlxm)
'Nom de l'onglet cible (OIL EDU)
'copier les données du fichier source (OIL) dans le fichier cible (OIL EDU)
ChDir "C:\Users\brenaud\Desktop\EDU CAB TEST\DR EDU CAB" 'Parcourir le contenu du dossier DR EDU CAB
ClasseurRegional = Dir("C:\Users\brenaud\Desktop\EDU CAB TEST\DR EDU CAB\*.xlsx""OIL")
While Len(ClasseurRegional) > 0 'Tant que la longueur de (ADD0000130198 - TEST 07 POUR DESIGN REVIEW - MARSEILLE.xlxm) est de 59 caractères, donc 59 > 0...
Workbooks.Open ClasseurRegional 'On ouvre le classeur DR EDU CAB onglet OIL
AvantDerniereLigne = ActiveSheet.UsedRange.Rows.Count - 1
Range("A8:X" & AvantDerniereLigne).Copy
Workbooks("00_ENG-RS-VPF-FRM-0XX_A_OIL EDU-CAB_DR3D_FTA_BDI.xlxm\OIL EDU").Activate 'Notre fichier cible et son onglet OIL EDU
DebutNomFichier = ActiveSheet.UsedRange.Rows.Count + 8 'on commence à la ligne N°8
Range("A" & ActiveSheet.UsedRange.Rows.Count + 8).Select 'on copie les éléments de la colonne A en ligne 8
Range("B" & ActiveSheet.UsedRange.Rows.Count + 8).Select 'on copie les éléments de la colonne B en ligne 8
Range("C" & ActiveSheet.UsedRange.Rows.Count + 8).Select 'on copie les éléments de la colonne C en ligne 8
Range("D" & ActiveSheet.UsedRange.Rows.Count + 8).Select 'on copie les éléments de la colonne D en ligne 8
Range("E" & ActiveSheet.UsedRange.Rows.Count + 8).Select 'on copie les éléments de la colonne E en ligne 8
Range("F" & ActiveSheet.UsedRange.Rows.Count + 8).Select 'on copie les éléments de la colonne F en ligne 8
Range("G" & ActiveSheet.UsedRange.Rows.Count + 8).Select 'on copie les éléments de la colonne G en ligne 8
Range("H" & ActiveSheet.UsedRange.Rows.Count + 8).Select 'on copie les éléments de la colonne H en ligne 8
Range("I" & ActiveSheet.UsedRange.Rows.Count + 8).Select 'on copie les éléments de la colonne I en ligne 8
Range("K" & ActiveSheet.UsedRange.Rows.Count + 8).Select 'on copie les éléments de la colonne K en ligne 8
Range("N" & ActiveSheet.UsedRange.Rows.Count + 8).Select 'on copie les éléments de la colonne N en ligne 8
Range("R" & ActiveSheet.UsedRange.Rows.Count + 8).Select 'on copie les éléments de la colonne R en ligne 8
Range("S" & ActiveSheet.UsedRange.Rows.Count + 8).Select 'on copie les éléments de la colonne S en ligne 8
Range("T" & ActiveSheet.UsedRange.Rows.Count + 8).Select 'on copie les éléments de la colonne T en ligne 8
Range("V" & ActiveSheet.UsedRange.Rows.Count + 8).Select 'on copie les éléments de la colonne V en ligne 8
Range("X" & ActiveSheet.UsedRange.Rows.Count + 8).Select 'on copie les éléments de la colonne X en ligne 8
ActiveSheet.Paste
Workbooks(ClasseurRegional).Close 'On ferme le classeur DR EDU CAB
Range("A" & DebutNomFichier & ":A" & ActiveSheet.UsedRange.Rows.Count) = ClasseurRegional 'On écrit en colonne A le nom du fichier.xlsm copié
ClasseurRegional = Dir 'on lit le fichier suivant
Wend ' Comme la longueur de (GPE - ADD0000130198 - TEST 06 POUR DESIGN REVIEW.xlxm) est > 0, on recommence, et ainsi de suite ...
End Sub
J'ai trouvé
Sub CopierOIL()
'Adresse du Fichier source (C:\Users\brenaud\Desktop\EDU CAB TEST\DR EDU CAB)
'Nom des fichiers source (.xlsm)
'Nom de l'onglet source (OIL)
'Adresse du Fichier cible (C:\Users\brenaud\Desktop\EDU CAB TEST)
'Nom du fichier cible (00_ENG-RS-VPF-FRM-0XX_A_OIL EDU-CAB_DR3D_FTA_BDI.xlsm)
'Nom de l'onglet cible (OIL EDU)
Range("A8").Select 'sélectionner la cellule de début
Chemin = "C:\Users\brenaud\Desktop\EDU CAB TEST\DR EDU CAB\" 'Indiquer ici le chemin complet du dossier où se trouvent les fichiers
Fichier = Dir(Chemin & "*.xlsm") ' Premier fichier
Do While Fichier <> ""
Workbooks.Open Filename:=Chemin & Fichier
Range("'OIL'!$A$8:$X$38").Copy 'ici nommer la plage de la feuille à copier
ThisWorkbook.Activate
ActiveSheet.Paste
Windows(Fichier).Activate
Application.CutCopyMode = False
ActiveWorkbook.Close savechanges:=False
ThisWorkbook.Activate
Range("A65536").End(xlUp).Offset(1, 0).Select
Fichier = Dir ' Fichier suivant
Loop
End Sub
Même si je n'ai pas eu de réponse, en fouillant dans les anciens "posts" et en cherchant par moi-même j'ai pu trouver la solution à mon problème
Merci à vous