Commande VBa pour importer des données de nouveaux classeurs d'un dossier [Résolu]

[ronaindor]

Bonjour,

Je suis nouveau sur ce forum mais cela fait déjà un moment que je viens lire certaines discussions qui me sont toujours très utiles. C'est donc pour cela que j'implore votre savoir faire pour mon problème qui est le suivant:

Le but de la macro est d'importer une plage de données provenant de chaque classeur d'un dossier dans un nouveau classeur.

Dans ce nouveau classeur, le souhait est d'avoir une feuille par plage de données prélevées dans chaque classeur du dossier. Ces feuilles doivent porter le nom du classeur d'où proviennent les données.

Il faudrait également qu'à chaque lancement de ce nouveau classeur il vérifie si de nouveaux classeurs ont été importés dans le dossier. Si c'est le cas, il faut qu'il importe une plage de données de ce classeur dans une nouvelle feuille portant son nom.

Je ne sais pas si j'ai été clair mais en tout cas j'ai fait tout mon possible pour l'être.
J'ai vraiment besoin d'aide car mon niveau de connaissances en VBa est trop faible pour réussir à réaliser une telle macro.

Merci d'avance pour votre aide.
Cordialement

[Daniel.C]

La plage de données est-elle la même pour chaque classeur ? Les feuilles contenant le s données à importer ont-elles le même nom ? lequel ? A titre d'exemple :

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
Sub Import()
    Dim Chemin As String, Fich As String, Plage As String, NomFeuille As String
    Dim Teste As Boolean, Sh As Worksheet
    Chemin = "c:\temp"     '*** à modifier
    Plage = "A1:L100"     '*** à modifier
    NomFeuille = "Feuil1"     '*** à modifier
    Fich = Dir(Chemin & "\*.xls*")
    Do While Fich <> ""
        Teste = False
        For Each Sh In ThisWorkbook.Worksheets
            If Sh.Name = Fich Then
                Teste = True
                Exit For
            End If
        Next Sh
        If Teste = False Then
            Sheets.Add.Name = Fich
            Workbooks.Open Chemin & "\" & Fich
            Sheets(NomFeuille).Range(Plage).Copy
            ThisWorkbook.Sheets(Fich).[A1].PasteSpecial xlPasteValues
            ActiveWorkbook.Close False
        End If
    Fich = Dir
    Loop
End Sub

[ronaindor]

Bonjour et tout dabord merci pour la rapidité de votre réponse!

La plage de données est effectivement la meme pour chaque classeur (A3:G57) et les feuilles comportant les données ont le meme nom : Emissions (g)

Merci pour l'attention que vous portez à ma requète.
Cordialement

[Daniel.C]

Dans un module standard :

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
Sub Import()
    Dim Chemin As String, Fich As String, Plage As String, NomFeuille As String
    Dim Teste As Boolean, Sh As Worksheet
    Chemin = "c:\temp"     '*** à modifier
    Plage = "A3:G57"     '*** à modifier
    NomFeuille = "Emissions (g)"     '*** à modifier
    Fich = Dir(Chemin & "\*.xls*")
    Do While Fich <> ""
        Teste = False
        For Each Sh In ThisWorkbook.Worksheets
            If Sh.Name = Fich Then
                Teste = True
                Exit For
            End If
        Next Sh
        If Teste = False Then
            Sheets.Add.Name = Fich
            Workbooks.Open Chemin & "\" & Fich
            Sheets(NomFeuille).Range(Plage).Copy
            ThisWorkbook.Sheets(Fich).[A1].PasteSpecial xlPasteValues
            ActiveWorkbook.Close False
        End If
    Fich = Dir
    Loop
End Sub

Tu dois modifier la ligne 4 pour indiquer le chemin de ton dossier.

Dans le module "ThisWorkbook", colle la macro :

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
Private Sub Workbook_Open()
    Dim Chemin As String, Fich As String, Plage As String, NomFeuille As String
    Dim Teste As Boolean, Sh As Worksheet
    Chemin = "c:\temp"     '*** à modifier
    Plage = "A3:G57"     '*** à modifier
    NomFeuille = "Emissions (g)"     '*** à modifier
    Fich = Dir(Chemin & "\*.xls*")
    Do While Fich <> ""
        Teste = False
        For Each Sh In ThisWorkbook.Worksheets
            If Sh.Name = Fich Then
                Teste = True
                Exit For
            End If
        Next Sh
        If Teste = False Then
            Sheets.Add.Name = Fich
            Workbooks.Open Chemin & "\" & Fich
            Sheets(NomFeuille).Range(Plage).Copy
            ThisWorkbook.Sheets(Fich).[A1].PasteSpecial xlPasteValues
            ActiveWorkbook.Close False
        End If
    Fich = Dir
    Loop
End Sub

Tu dois modifier la même ligne. Grâce à cette seconde macro, à l'ouverture du classeur le code ira vérifier la présence de nouveaux classeurs.

[ronaindor]

Ok super merci!

Mais le problème c'est que j'ai un message d'erreur lorsque je lance la macro...

Je vous joins une capture d'écran de l'erreur.

Merci

Cordialement

[Daniel.C]

Ce qui pose un problème si tu as des noms de fichiers de plus de 31 caractères, même si l'on ne tient pas compte de l'extension (.xls). Si l'on tronque les noms à 31 caractères, ne risque-t-il pas d'y avoir des doublons ? dans ce cas, comment les traiter ?

[ronaindor]

Bonjour,

Effectivement le problème venait bien de la taille du nom de mon fichier (52 caractères sans l'extension).

Si l'on tronque les noms à 31 caractères il n'y aura aucun problème de doublons.

Merci pour votre aide !

[Daniel.C]

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
Sub Import()
    Dim Chemin As String, Fich As String, Plage As String, NomFeuille As String
    Dim Teste As Boolean, Sh As Worksheet
    Chemin = "c:\temp"     '*** à modifier
    Plage = "A3:G57"     '*** à modifier
    NomFeuille = "Emissions (g)"     '*** à modifier
    Fich = Dir(Chemin & "\*.xls*")
    Do While Fich <> ""
        Teste = False
        For Each Sh In ThisWorkbook.Worksheets
            If Sh.Name = Left(Fich, 31) Then
                Teste = True
                Exit For
            End If
        Next Sh
        If Teste = False Then
            Sheets.Add.Name = Left(Fich, 31)
            Workbooks.Open Chemin & "\" & Fich
            Sheets(NomFeuille).Range(Plage).Copy
            ThisWorkbook.Sheets(Fich).[A1].PasteSpecial xlPasteValues
            ActiveWorkbook.Close False
        End If
    Fich = Dir
    Loop
End Sub

[ronaindor]

Super ca marche !!!

Merci beaucoup Daniel !!!

Bonjour,

Je me suis rendu compte qu'il fallait aussi que je fasse la meme chose avec les fichiers contenu dans les sous dossiers.

Pourriez vous m'aider à trouver la solution ?


Merci.

[Daniel.C]

Essaie comme ceci (non 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 Import()
    Dim Chemin As String, Fich As String, Plage As String, NomFeuille As String
    Dim Teste As Boolean, Sh As Worksheet
    Chemin = "c:\temp"     '*** à modifier
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set dossier_racine = fso.getfolder(Chemin)
    SousDossiers dossier_racine
End Sub
 
Sub SousDossiers(dossier)
    Plage = "A3:G57"     '*** à modifier
    NomFeuille = "Emissions (g)"     '*** à modifier
    For Each d In dossier.SubFolders
      SousDossiers d
    Next
    For Each f In dossier.Files
        If IsNumeric(InStr(1, f.Name, "xls")) Then
            Teste = False
            For Each Sh In ThisWorkbook.Worksheets
                If Sh.Name = Left(f.Name, 31) Then
                    Teste = True
                    Exit For
                End If
            Next Sh
            If Teste = False Then
                Sheets.Add.Name = Left(f.Name, 31)
                Workbooks.Open f
                Sheets(NomFeuille).Range(Plage).Copy
                ThisWorkbook.Sheets(Left(f.Name, 31)).[A1].PasteSpecial xlPasteValues
                ActiveWorkbook.Close False
            End If
        End If
    Next
End Sub

[ronaindor]

Ca marche ! Une fois de plus merci !

J'avais juste oublié de préciser que la macro ne doit ouvrir que les fichiers excel qui ont un nom où l'on peut trouver le texte "StandardReport".

Par exemple les fichiers de types: "*StandardReport*.xls*"

Pourriez-vous m'aider à réaliser cela ?

Merci

[Daniel.C]

Hmm... C'était presque bon.Remplace la ligne :

Code :

If IsNumeric(InStr(1, f.Name, "xls")) Then

par la ligne :

Code :

If InStr(1, f.Name, "StandardReport") > 0 And InStr(1, f.Name, "xls") > 0 Then

[ronaindor]

Super !!!

Je ne sais comment vous remercier !!!


Sans vous je n'y serai jamais arrivé...

En tout cas je suis fier de l'entraide présente sur le net et j'éspère que le partage des savoirs y perdurera !


Merci encore

[Daniel.C]

Merci du retour. Marque la discussion comme résolue, ça aidera ceux qui cherchent dans les archives du forum.