Synthétiser des fichiers

[triviani]

Bonjour à tous,

Ds mon entreprise tout se fait sur Excel. Or, je pense que certaines tâches pourraient etre automatisées.
Je reçois en effet mensuellement des fichiers excel contenant les dépenses réalisées par les bureaux régionaux. J'aimerai synthétiser ces fichiers (il y en a quand meme plus de 300 par mois).
Plutot qu'une longue description, je prefere vous laisser regarder les fichiers joints qui seront plus parlant.
En résumé, je souhaite juste afficher dans un tableau le :
nom du bureau 1, sa dépense;
nom du bureau 2, sa dépense;
nom du bureau 3, sa dépense;
etc...
Il n'y a donc aucun calcul, simplement aller chercher pour chaque fichier les valeurs correspondantes ds les cases, et les mettre à la suite.

En cherchant ds le forum, j'ai vu des choses qui s'en approchaient mais pas tout à fait pareil. J'ai vu ds une discussion qu'il ne fallait pas que la macro ouvre les fichiers les uns après les autres mais plutôt utiliser ce code :

Application.ScreenUpdating = False
pfile = ActiveWorkbook.Path & "\archive\" 'indiquer ici le chemin du répertoire
nfile = Dir(pfile)
i = 2
Do Until nfile = ""

Merci d'avance à tous ceux qui pourront m'aider.

 

[Grand Chaman Excel]

Re : Synthétiser des fichiers

Bonjour triviani et bienvenue sur le forum,

Voir ces liens qui je crois pourraient s'adapter à ton cas.

Le Grand Chaman Excel: VBA | Récupérer les données de plusieurs fichiers
Le Grand Chaman Excel: VBA | Récupérer les données de plusieurs fichiers (2); Fonction DIR

A+

 

[Gareth]

Re : Synthétiser des fichiers

Bonsoir,

Ci-joint une macro à tester

 

[triviani]

Re : Synthétiser des fichiers

Salut Gareth,

Excellent ton code.
Pourrait on l'améliorer ? ESt il possible de faire en sorte non plus qu'il aille chercher les deux cellules B1 et B2 mais C4 et G13 par exemple?

Merci d'avance

Sub Test()
Application.ScreenUpdating = False 'Gel écran
ThisWorkbook.Sheets("Sheet1").[B2].CurrentRegion.Offset(1, 0).Clear 'Efface la zone destination
Chemin = ThisWorkbook.Path 'Chemin = chemin du classeur actif
Fichier = Dir(Chemin & "\*.xlsx") 'Début de liste des fichiers
Do While Fichier <> "" 'Boucle sur les fichier du dossier
    If Fichier <> ThisWorkbook.Name Then 'Si le nom de fichier est différent du fichier courant
        Workbooks.Open Filename:=Chemin & "\" & Fichier 'Ouvrir le fichier
        Workbooks(Fichier).Sheets("Sheet1").Range("B1:B2").Copy 'Copie des données
        ThisWorkbook.Sheets("Sheet1").Range("B60000").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True 'Collage transposé
        Workbooks(Fichier).Close False 'Fermeture du fichier
    End If
    Fichier = Dir
Loop
ThisWorkbook.Sheets("Sheet1").Range("B2").Select
Application.ScreenUpdating = True
End Sub

 

[Gareth]

Re : Synthétiser des fichiers

Bonjour,

Sans l'améliorer mais en le modifiant, on peut le faire ...
Voir le fichier joint

 

[triviani]

Re : Synthétiser des fichiers

Merci pour cette amélioration Gareth, la macro fait exactement ce qu'il faut.

En pratique, il reste toutefois un petit problème : la macro ouvre les fichiers pour aller copier la donnée, or cela pose deux problèmes :
1 cela augmente le temps de traitement
2 cela entraine une erreur pour les fichiers qui m'ont été retournés par mail et que Microsoft considère comme dangereux

Est il possible de faire la macro avec exactement la même fonctionnalité en utilisant une formule de macro que j'ai trouvé dans une autre discussion et qui n'ouvre pas les fichiers ?
Je mets le code en dessous :

Sub Macro1()
Application.ScreenUpdating = False
pfile = ActiveWorkbook.Path & "\archive\" 'indiquer ici le chemin du répertoire
nfile = Dir(pfile)
i = 2
Do Until nfile = ""
    texte = "'" & pfile & "[" & nfile & "]FORMULAIRE'!"
    Cells(i, 8).FormulaArray = "=COUNTA(" & texte & "$C$18:C118)"
    For j = 1 To Cells(i, 8)
        Cells(i, 1) = Year(Date)
        Cells(i, 2) = Int((Month(Date) + 2) / 3)
        Cells(i, 3) = "=" & texte & "$C$4"
        Cells(i, 4) = "=IF(" & texte & "$C$5=""""," & texte & "$C$6," & texte & "$C$5)"
        Cells(i, 5) = "=" & texte & "$B$" & j + 17
        Cells(i, 6) = "=" & texte & "$C$" & j + 17
        Cells(i, 7) = "=" & texte & "$E$" & j + 17
        i = i + 1
    Next
    nfile = Dir()
Loop
Columns(8).Cells.Clear
With Range("A2:G" & Range("A65000").End(xlUp).Row)
    .Value = .Value
End With
End Sub

Merci

 

[Gareth]

Re : Synthétiser des fichiers

Bonsoir,

Ci-joint une adptation de ma macro qui n'ouvre pas les fichiers