Synthese fichiers Excel d'un dossier

Version imprimable

28/12/2006, 21h02
Manu_111

Synthese fichiers Excel d'un dossier

Bonsoir à tous,

Voici mon pb.
J'ai un dossier contenant une centaine de fichiers Excel ayant tous exactement le même format. Il s'agit de devis.

Chaque jour, des nouveaux devis s'ajoutent dans ce dossier. Aucun de ces classeurs Excel n'a le même nom.

Mon objectif serait de créer une base de données sous Excel. Imaginons qu'elle s'appelle "FUSION". Je voudrais par exemple récupérer dans chaque devis la cellule contenant la date, le nom du client....etc...
Dans "Fusion", je voudrais cliquer sur un bouton qui me permettrait d'actualiser la base de données des devis sans que j'ai à ouvrir à chaque fois les devis pour récupérer les données qui m'intéressent.

Pouvez vous m'aider grâce à un exemple?
Merci d'avance
28/12/2006, 22h32
avigeilpro

va sur mon site, tu y trouvera un controle te permettant de piloter Excel. Si tu veux les sources donne moi ton mail par MP.
Pour parcourir tous les fichiers, utilise Dir ou passe par FileSystemObject (fait une petite recherche sur le forum tu y trouvera ton bonneur)
Après ce n'est que question de boucles et autres manipulations du genre.

Tiens voila un petit coup de main: le code suivant parcours le dossier "C:\Mes Fichiers" et récuppère l'adresse de tous les fichiers xls qui sont dedans. Ne reste plus qu'a les traiter :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 Dim FileAdr As String Dim Dossier As String Dim Extension As String Dossier = "C:\Mes Fichiers\" Extension = "*.xls" FileAdr = Dir(Dossier & Extension) While FileAdr <> "" FileAdr = Dossier & FileAdr 'Traitement du fichier '... '... '... '... FileAdr = Dir Wend
Surtout n'oublie pas le "\" à la fin de la chaine Dossier, il est très important ;)

suite

voici ce que j'ai fait.
Mon fichier base de données s'appelle FUSION
J'ai mis 3 fichiers excel dans un dossier appelé TEST

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
Sub Regroupement()
 
Application.ScreenUpdating = False
 
Sheets("Feuil1").Select
Range("B4:D4").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Clear
 
monfichier = Dir("C:\Test\*.xls", vbReadOnly)
 
While monfichier <> ""
    Workbooks.Open monfichier
    Sheets("Feuil1").Select
    Range("A6:C6").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Workbooks(2).Close SaveChanges:=False
    GoSub coller
    monfichier = Dir()
Wend
    Cells(ligne + 1, 2).Select
Exit Sub
 
coller:
    ligne = 4
    Do While Sheets("Feuil1").Cells(ligne, 2) <> ""
        ligne = ligne + 1
    Loop
    Cells(ligne, 2).Select
    ActiveSheet.Paste
    Return
 
End Sub

Cependant, ca ne marche pas. J'ai un message qui m'indique que les 3 fichiers excel de mon dossier n'existent pas...

Si kelk1 peut m'aider...
Bonnes fêtes

29/12/2006, 07h23
Pierre Fauconnier
Bonjour

C'est normal, si c:\test n'est pas ton dossier courant.

Dès lors, pour ouvrir ton fichier, tu dois spédcifier le chemin d'accès et utiliser
Code:

1 2 Workbooks.Open "c:\test\" & MonFichier
Cela étant, il y a beaucoup de select dans ton code. Tu peux utilement remplacer les select en travaillant directement sur l'objet Range voulu

Par exemple,
Code:

1 2 3 4 Range("B4:D4").Select Range(Selection, Selection.End(xlDown)).Select Selection.Clear
peut être remplacé par
Code:

1 2 Range("b4:d" & Range("b65536").End(xlUp).Row).Clear
pour rendre ton code plus efficace.

Ok?
29/12/2006, 09h45
Manu_111

suite2

Merci bcp pour l'aide, je débute dans VBA...

Par contre, lorsque je lance la macro, j'ai le message du presse papiers qui apparait à chaque fois. Je dois à chaque fois cliquer sur oui.

Connaissez vous la routine pour répondre oui à chacune des questions du presse papiers et ne pas voir ce message apparaitre à l'écran?

Merci d'avance

En fait, je pense que tout ton code est à revoir...

Pour ma part, j'utiliserais les objets, notamment WorkBooks, workSheets et Range

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
 
Sub Regroupement()
Dim MonFichier As String
Dim wbAppli As Workbook ' Classeur cible pour le regroupement
Dim wbDevis As Workbook ' Classeur source
Dim shSource As Worksheet ' Feuille source du classeur source
Dim shCible As Worksheet ' Feuille cible du classeur cible
Dim CelCible As Range
 
Application.ScreenUpdating = False
 
Set wbAppli = ThisWorkbook ' wbappli correspond au classeur cible
Set shCible = ActiveSheet ' shCible correspond à la feuille récapitulative, c-a-d la feuille active du classeur cible
 
shCible.Range("b4:d" & shCible.Range("b65536").End(xlUp).Row).Clear ' Vidande de la feuille
 
MonFichier = Dir("C:\test\*.xls", vbReadOnly)
While MonFichier <> ""
    Set CelCible = shCible.Range("b65536").End(xlUp)(2) ' On détermine quelle cellule recevra le collage
    Set wbDevis = Workbooks.Open("c:\test\" & MonFichier) ' On ouvre le fichier source
    Set shSource = wbDevis.Worksheets("feuil1") ' on attribue à l'objet shSource l'onglet Feuil1 du classeur source
    shSource.Range("A6:C" & shSource.Range("a65536").End(xlUp).Row).Copy Destination:=CelCible ' on copie-colle en une fois
    Workbooks(2).Close SaveChanges:=False ' on ferme la source
    MonFichier = Dir() ' on itère
Wend
End Sub

Je n'ai pas testé, mais cela devrait fonctionner

Tu reviens et tu nous dis quoi?