Excel Macro Extraction Données [Résolu/Fermé]

Signaler
-
 Faren -
Bonjour,

Je suis assez débutant en macros excel, et j'aimerais obtenir de l'aide pour créer une macro d'extraciton sur excel. J'ai plusieurs fichiers avec 11 colonnes et 33 lignes tous sous le meme format et j'aimerais créer un fichier distinct qui va extraire les données dans les tableaux de mes fichiers pour les mettres un à la suite de l'autre dans le classeur source. Tous les fichiers sont au même endroit sur mon ordinateur.

Le but étant de mettre éventuellement des filtres et retrouver l'information réunie dans un même fichier plus rapidement.

Merci beaucoup de votre dévoument

Martin

28 réponses

Messages postés
9745
Date d'inscription
mercredi 11 août 2004
Statut
Contributeur
Dernière intervention
24 juillet 2020
1 061
Bonjour,
Eh bien, je pense qu'il est préférable d'ouvrir un nouveau poste avec une explication et si possible le fichier sur https://www.cjoint.com/ et poster le lien.

3
Merci

Quelques mots de remerciements seront grandement appréciés. Ajouter un commentaire

CCM 57031 internautes nous ont dit merci ce mois-ci

Bonjour,

voici les fichiers http://cjoint.com/?BKhq5upu2WM.
Messages postés
12184
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
31 juillet 2020
2 463
Bonjour,

J'ai plusieurs fichiers
Combien?
10-15 par semaine...

j'ai vu sur internet quelqu'un qui faisait a peu près le même genre d'action avec un bouton de transfert...

Martin
Messages postés
12184
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
31 juillet 2020
2 463
Oui c'est possible.
Le tout est de savoir combien de données va "drainer" à terme ton fichier excel.
Là, selon ton indication et à condition d'un fichier regroupement de données par an ça fait tout de même :
15*52*33 = 25 740 lignes et 11 colonnes.
Ca pourrait encore passer.
J'te bricole une solution vite fait et tu testes.
OK?
Parfait merci beaucoup :)
Messages postés
12184
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
31 juillet 2020
2 463
Petite question importante, tes fichiers sont dans le même répertoire. Ok.
Mais toutes les semaines, tu ajoutes des fichiers dans le même répertoire? Dans un autre?
Dans le même
Messages postés
12184
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
31 juillet 2020
2 463
Voici un premier jet :

https://www.cjoint.com/?BChq5ZwmMN1

Le code :
Option Explicit

Sub ExtractionDonnéesClasseursMultiples()
Dim objShell As Object, objFolder As Object
Dim Chemin As String, fichier As String

With Sheets("Extraction")
    .Cells.Clear
End With
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&)

If objFolder Is Nothing Then
    MsgBox "Abandon opérateur", vbCritical, "Annulation"
Else
    Chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path & "\"
    fichier = Dir(Chemin & "*.xls")
    With Sheets("Extraction")
        .[A1] = fichier
    End With
    Do While Len(fichier) > 0
        If fichier <> ThisWorkbook.Name Then
            ThisWorkbook.Names.Add "Plage", _
            RefersTo:="='" & Chemin & "[" & fichier & "]Feuil1'!$A$1:$L$50"
            With Sheets("Feuil2")
                .[A1:L50] = "=Plage"
                .[A1:L50].Copy
                Sheets("Extraction").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            End With
        End If
        fichier = Dir()
        With Sheets("Extraction")
            .Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = fichier
        End With
    Loop
End If
With Sheets("Feuil2")
    .[A1:L50].Clear
End With
End Sub

Je test, Merci beaucoup encore pijaku
Messages postés
12184
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
31 juillet 2020
2 463
De rien.
Il y a plein de défaut à cette méthode.
Par exemple : les cellules vides sont remplacées par un 0...
Essaye et reviens pour les adaptations...
Ok,
Je peux créer un bouton de commande et y associer ce code ?
Messages postés
12184
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
31 juillet 2020
2 463
j'obtiens un bug à la ligne ci dessous :

.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(UBound(Tabl, 2), UBound(Tabl, 1)) = Application.Transpose(Tabl)

Faut-il que j'adapte quelque chose ?
Mes fichiers a extraires s'appellent Abcde1, Abcde2, Abcde3 et les feuilles dans ces fichiers qu'il faut extraire s'appellent toutes Feuil1, si ça peut t'aider ...

Merci pour ton temps

Martin
Messages postés
12184
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
31 juillet 2020
2 463
Re-
j'obtiens un bug à la ligne ci dessous :

.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(UBound(Tabl, 2), UBound(Tabl, 1)) = Application.Transpose(Tabl)

Faut-il que j'adapte quelque chose ?


Je ne comprends pas, je viens de re-tester cela fonctionne.

Peut être du à un de tes fichiers ou aux données qu'il contient. Peux tu me faire passer un exemple ici même?
La feuille extraction me donne :

en A1 A2 et A3, à la fin de l'exécution :

Extraction.xls
Abcde1.xls
Abcde2.xls
Abcde3.xls

Mais il ne copie pas les tableaux comme j'aurais espéré...
Il me demande d'enregistrer les fichiers à extraire à la fin de l'exécution, maisles tableaux ne sont pas copiés dans le fichier source... lorsque j'enregistre les fichiers j'obtiens ce que j'ai écris dans la dernière réponse ^

Les fichiers à extraire contiennent des listes (validations de données) et les différences de couleurs de cellules.
Messages postés
12184
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
31 juillet 2020
2 463
Salut,
Peux tu me transmettre, grâce à https://www.cjoint.com/ ou par mail (tu trouveras mon adresse perso en fouillant dans mon profil), un exemple de fichier.
Tu va sur cjoint, tu créées un lien vers ton fichier, copie ce lien et viens le coller ici dans une réponse.
Voici le fichier :
http://cjoint.com/confirm.php?cjoint=BCio1q6QOhu

Voici le fichier source :
http://cjoint.com/confirm.php?cjoint=BCio2BbEqIP

Le but étant que lorsque j'appuie sur transférer le fichier source copie et colle le tableau dans sa feuille d'extraction.

Merci pijaku
Messages postés
12184
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
31 juillet 2020
2 463
Je ne peux pas ouvrir les fichiers .xlsm... Donc ne peux pas ouvrir abcde...
Peux tu l'enregistrer sous, type de fichier : classeur excel 97-2003 et me le transférer à nouveau...
http://cjoint.com/confirm.php?cjoint=BCipt1URiI1

J'ai été obligé de supprimer la deuxième feuille puisqu'elle était trop lourde. Il s'agit d'une feuille de référence pour les projets.
Messages postés
12184
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
31 juillet 2020
2 463
En effet, bien peu de choses peuvent empêcher le bon fonctionnement d'une procédure...
Ici, il suffit de préciser la feuille. Soit :
Tabl = Sheets("Feuil1").Range("A9:K42") ' A ADAPTER SI PLUS DE 11 Colonnes et 33 Lignes...

au lieu de :
Tabl = Range("A9:K42") ' A ADAPTER SI PLUS DE 11 Colonnes et 33 Lignes...


ton fichier extraction
Messages postés
9745
Date d'inscription
mercredi 11 août 2004
Statut
Contributeur
Dernière intervention
24 juillet 2020
1 061
Bonjour pijaku,
Je n'avais pas remarqué m'est il me semble que c'était votre code :
https://forums.commentcamarche.net/forum/affich-24654554-macro-extraction-donnees-excel#1
Amicales salutations.
Le Pingou
Messages postés
12184
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
31 juillet 2020
2 463
Salut Le Pingou,

Oui je viens de voir ce doublon. Et oui, par moment je ne réponds pas assez rapidement...

On peux peut être se tutoyer non?
Franck
Merci Beaucoup de votre temps, je suis très satisfait, c'est exactement ce que j'espérais :)

Bonne journée
Messages postés
12184
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
31 juillet 2020
2 463
as tu supprimé comme te le disais fort justement Le Pingou la seconde :
With Sheets("Extraction")
    .Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(UBound(Tabl, 2), UBound(Tabl, 1)) = Tabl
End With

??
Messages postés
12184
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
31 juillet 2020
2 463
Parfait donc.
A+
Messages postés
9745
Date d'inscription
mercredi 11 août 2004
Statut
Contributeur
Dernière intervention
24 juillet 2020
1 061
Bonjour pijaku,

A la question : On peux peut être se tutoyer non? ; depuis le temps que l'on se croise sur le site et si vous êtes le violoniste Frank je pense que Oui.
Je te souhaite une excellent fin de journée.
Amicales sautations
Le Pingou
Messages postés
12184
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
31 juillet 2020
2 463
Salut
Yes I'm this Franck.

On s'connait???

A+

Franck
Messages postés
9745
Date d'inscription
mercredi 11 août 2004
Statut
Contributeur
Dernière intervention
24 juillet 2020
1 061
Bonjour,
Non, cependant, il y a un certain temps tu m'avais invité à l'occasion d'un MP à jeter un oeil sur 4 Smyki.
Maintenant les choses sont à leurs places dans ... et c'est super.
A une prochaine.
Salutations amicales
Le Pingou
Oh, une dernière chose,

J'ai remarqué qu'il transposait les colonnes en lignes, est-ce possible qu'il ne le fasse pas ?

seulement copier les lignes en lignes et les colonnes en colonnes ?
Messages postés
12184
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
31 juillet 2020
2 463
Vois ce qui te convient le mieux...

With Sheets("Extraction")
    .Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(UBound(Tabl, 2), UBound(Tabl, 1)) = Tabl
End With

ou

With Sheets("Extraction")
    .Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(UBound(Tabl, 2), UBound(Tabl, 1)) = Application.Transpose(Tabl)
End With
Rebonjour,

Je ne sais pas si j'aurais du créer un nouveau post, mais j'avais en fait deux questions.

La première est-ce possible de ne pas copier les lignes sans écritures ?

La deuxième est-ce possible de ne pas effacer les cellules au début de l'extraction, mais bien de poursuivre à la suite des dernières lignes extraites si l'on fait plusieurs extractions en série ?

Merci de ton service après-vente pijaku :)
Messages postés
12184
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
31 juillet 2020
2 463
demain?
j'ai réglé mon problème avec les filtres et masquer les cellules vides automatiquement.

J'ai aussi changé le .clear cells pour un DerniereLigne = Range("A65536").End(xlUp).Row

et tout fonctionne très bien