Récupération de données avec adresse et identification de la feuille en variable

[chimonito]

Bonjour à tous !

Cela faisait un moment que je n'avais pas touché excel, mais là me revoilà et j'avoue je bug un peu !!!

J'ai une macro pour récupérer des données dans différents fichiers excel sur un répertoire se trouvant sur mon réseau au boulot. Chaque fichier excel porte le même nom de feuille ex : Janvier dans un fichier a.xlsx ; Janvier dans un fichier b.xlsx, ...

J'aimerais une macro qui me permette de récupérer sur mon fichier synthese.xlsm, toutes les données se trouvant dans ces fichiers, mais là où cela se complique pour moi, je dis bien pour moi, c'est que dans mon fichier synthèse, j'ai une feuille paramètre où dedans se trouve en A2 une valeur qui correspond à mon adresse de répertoire ex : C:\Users\Benji\Desktop\Nouveau dossier (3) et en A5 une valeur correspondant à la feuille source des données à récupérer, ex Janvier.
Pourquoi ça tout simplement parce que c'est un fichier que je vais adapter suivant le répertoire et le nom de la feuille source et que je préfère changer la valeur d'une cellule que de devoir rentrer à chaque fois dans mes macros.

Voici mon code :


Sub CreationSynthese()
Dim repertoire As String
Dim page As String

Application.ScreenUpdating = False

Cells.Delete

Range("A1") = "Mois"
Range("B1") = "Catégorie"
Range("C1") = "Formation"

Repertoire = Sheets("parametre").Range("A2").Value '=C:\Users\Benji\Desktop\Nouveau dossier (3)
page = Sheets("parametre").Range("A5").Value '=Janvier

ChDir Repertoire
ClasseurRegional = Dir("*.xlsx")
While Len(ClasseurRegional) > 0
Workbooks.Open ClasseurRegional
Sheets(page).Select
AvantDerniereLigne = ActiveSheet.UsedRange.Rows.Count
Range("A2:F" & AvantDerniereLigne).Copy
Workbooks("synthese.xlsm").Activate
DebutNomFichier = ActiveSheet.UsedRange.Rows.Count + 1
Range("B" & ActiveSheet.UsedRange.Rows.Count + 1).Select
ActiveSheet.Paste
Range("A" & DebutNomFichier & ":A" & ActiveSheet.UsedRange.Rows.Count) = ClasseurRegional
Workbooks(ClasseurRegional).Close
ClasseurRegional = Dir

Wend

Columns("A:A").Replace ".xlsx", ""

Cells.EntireColumn.AutoFit

Range("A1").Select

Application.ScreenUpdating = True

End Sub



Si quelqu'un peut m'aider et éventuelle améliorer le code je suis preneur.

En vous remerciant énormément par avance

Benji

 

[Robert]

Bonjour Benji, bonjour le forum,

Pas sûr que le code soit amélioré niveau rendement mais, à mon avis, plus clair et mieux structuré :

Sub CreationSynthese()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim OP As Worksheet 'déclare la variable OP (Onglet Parametre)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim D As String 'déclare la variable D (Dossier)
Dim F As String 'déclare la variable F (Fichier)
Dim DLS As Integer 'déclare la variable DLS (Dernière Ligne Source)
Dim DLD As Integer 'déclare la variable DLD (Dernière Ligne Destination)

Application.ScreenUpdating = False
Set CD = ThisWorkbook 'définit le classeur destination CD
Set OD = CD.ActiveSheet 'définit longlet destination OD
Set OP = CD.Worksheets("parametre") 'définit l'onglet OP
OD.Cells.Delete 'efface les cellules de l'onglet OD
OD.Range("A1") = "Mois"
OD.Range("B1") = "Catégorie"
OD.Range("C1") = "Formation"
D = OP.Range("A2").Value 'définit le dossier D
F = Dir(D & "\*.xlsx") 'définit le premier fichier xlsx du dossier D
Do While F <> "" 'boucle tant qu'il existe des fichiers
    Workbooks.Open (D & "\" & F) 'ouvre le fichier F
    Set CS = ActiveWorkbook 'définit le classeur source CS
    Set OS = OP.Range("A5").Value 'définit l'onglet source CS
    DLS = OS.UsedRange.Rows.Count 'définit la dernière ligne éditée DLS de l'onglet source
    DLD = OD.Range("B" & ActiveSheet.UsedRange.Rows.Count + 1).Row 'définit la dernière ligne éditée DLD de l'onglet destination
    OS.Range("A2:F" & DLS).Copy OD.Cells(DLD, "B") 'copie la plage A2:F... de l'onglet source et la colle dans la cellule ligne DLD colonne B de l'onglet destination
    OD.Range(OD.Cells(DLD, "A"), OD.Cells(DLS, "A")).Value = F 'renvoie dans la colonne A le nom du fichier F
    CS.Close False 'ferme le classeur source sans enregistrer
    F = Dir 'définit la prochain fichier xlsx du dossier D
Loop 'boucle
OD.Columns("A:A").Replace ".xlsx", ""
OD.Cells.EntireColumn.AutoFit
OD.Activate
OD.Range("A1").Select
Application.ScreenUpdating = True
End Sub

 

[chimonito]

Salut Robert,

Merci pour le programme, en modifiant certaines choses, j'ai pu arriver à mes fins.

Si non le tiens marche bien.

Merci encore

Chimo