Fusion de plusieurs fichiers excel Le sujet est résolu

Y compris Power BI, Power Query et toute autre question en lien avec Excel
n
natou131
Jeune membre
Jeune membre
Messages : 32
Inscrit le : 11 mars 2011
Version d'Excel : 2003

Message par natou131 » 11 mai 2015, 18:17

Bonjour,

Je souhaiterais fusionner plusieurs fichiers excel en reportant dans un unique tableau les réponses aux questions posées.
Si cela est utile : tous les formulaires contenant les réponses seront dans un même dossier.

Ci-joint le formulaire de base qui sera fusionné.
Questionnaire Evaluation à chaud 2015 sans logo.xlsx
(11.99 Kio) Téléchargé 27 fois
Je n'ai pas de format spécifique pour la centralisation. Dans l'idéal j'aurai mis les questions en tête de colonnes et ensuite si la macro remplie ligne par ligne (1 ligne = 1 formulaire) çà me va !

Merci d'avance de votre aide !
Natacha
Avatar du membre
fred2406
Membre impliqué
Membre impliqué
Messages : 2'090
Appréciations reçues : 39
Inscrit le : 13 mai 2014
Version d'Excel : O365Pro-2019-2011MAC
Version de Calc : 6.3

Message par fred2406 » 11 mai 2015, 20:09

Bonsoir
voici une proposition
tous les fichiers du sondage doivent être dans un dossier et uniquement cela
le fichier joint doit être ailleurs ou tu veux mais ailleurs, tu trouveras le tiens que j'ai complété pour faire un essai

a chaque lancement il ya effacement des données présentent sur la feuille pour récupérer que les info des fichiers dans le dossier spécifique.
si tu veux faire des sous dossier pour un classement par exemple c'est possible faudra enlever quelques lignes qui sont en commentaires.
bon essais
Fred
natou.xlsm
(18.77 Kio) Téléchargé 91 fois
Questionnaire Evaluation à chaud 2015 sans logo.xlsx
(12.08 Kio) Téléchargé 40 fois
Je ne réponds pas aux M.P. non sollicités.
Ne pas oublier :
:btres:
Fred :O-O:
Avatar du membre
ThauThème
Passionné d'Excel
Passionné d'Excel
Messages : 3'887
Appréciations reçues : 182
Inscrit le : 19 octobre 2014
Version d'Excel : 2010 FR

Message par ThauThème » 11 mai 2015, 21:03

Bonsoir le fil, bonsoir le forum,

Arf ! Fred a été plus rapide... J'envoie quand même une autre proposition dont le principe est un peu différent. Contrairement à Fred, ce fichier doit se trouver dans le même dossier que les fichiers de questionnaire.
Sub Macro1()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim CH As String 'déclare la variable CH (Chemin d'Accès)
Dim F As String 'déclare la variable F (Fichier)
Dim J As Integer 'déclare la variable J (incrément)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim TC As Variant 'déclare la variable TC (Tableau de cellules)
Dim TL() As Variant ''déclare la variable TL (Tableau de Lignes)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set CD = ThisWorkbook 'définit le classeur destination CD
Set OD = CD.Sheets("Feuil1") 'définit l'onglet destination OD
OD.Range("A1").CurrentRegion.Offset(2, 0).ClearContents 'efface d'éventuelle anciennes données
CH = CD.Path 'définit le chemin d'accès CH
F = Dir(CH & "\*.xlsx") 'définit le nom du premier fichier Excel du dossier CH
J = 1 'initialise la variable J
Do While F <> "" 'agit tant que la variable F n'est pas vide
    If F <> CD.Name Then 'condition 1 : si F n'est pas ce fichier
        On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante
        Set CS = Workbooks(F) 'définit le classeur source CS (génère une erreur si ce classeur n'est pas ouvert)
        If Err <> 0 Then 'condition 2 : si une erreur a été générée
            Err.Clear 'supprime l'erreur
            Workbooks.Open (CH & "\" & F) 'ouvre le fichier F
            Set CS = ActiveWorkbook 'définit le classeur source CS
        End If 'fin de la condition 2
        On Error GoTo 0 'annule la gestion des erreurs
        Set OS = CS.Sheets("Questionnaire") 'définit l'onglet source OS
        TC = OS.Range("B5:B34") 'définit le tableau de cellules TC (la plage des réponses)
        ReDim Preserve TL(1 To 21, 1 To J) 'redimensionne le tableau de lignes TL (21 lignes, J colonnes)
        TL(1, J) = TC(1, 1) 'récupère la réponse 1 dans ligne 1 de TL
        TL(2, J) = TC(2, 1) 'récupère la réponse 2 dans ligne 2 de TL
        TL(3, J) = TC(3, 1) 'récupère la réponse 3 dans ligne 3 de TL
        TL(4, J) = TC(5, 1) 'récupère la réponse 4 dans ligne 4 de TL
        TL(5, J) = TC(6, 1) 'récupère la réponse 5 dans ligne 5 de TL
        TL(6, J) = TC(7, 1) 'récupère la réponse 6 dans ligne 6 de TL
        TL(7, J) = TC(8, 1) 'récupère la réponse 7 dans ligne 7 de TL
        TL(8, J) = TC(10, 1) 'récupère la réponse 8 dans ligne 8 de TL
        TL(9, J) = TC(13, 1) 'récupère la réponse 9 dans ligne 9 de TL
        TL(10, J) = TC(14, 1) 'récupère la réponse 10 dans ligne 10 de TL
        TL(11, J) = TC(15, 1) 'récupère la réponse 11 dans ligne 11 de TL
        TL(12, J) = TC(16, 1) 'récupère la réponse 12 dans ligne 12 de TL
        TL(13, J) = TC(19, 1) 'récupère la réponse 13 dans ligne 13 de TL
        TL(14, J) = TC(20, 1) 'récupère la réponse 14 dans ligne 14 de TL
        TL(15, J) = TC(21, 1) 'récupère la réponse 15 dans ligne 15 de TL
        TL(16, J) = TC(22, 1) 'récupère la réponse 16 dans ligne 16 de TL
        TL(17, J) = TC(23, 1) 'récupère la réponse 17 dans ligne 17 de TL
        TL(18, J) = TC(25, 1) 'récupère la réponse 18 dans ligne 18 de TL
        TL(19, J) = TC(28, 1) 'récupère la réponse 19 dans ligne 19 de TL
        TL(20, J) = TC(29, 1) 'récupère la réponse 20 dans ligne 20 de TL
        TL(21, J) = TC(30, 1) 'récupère la réponse 21 dans ligne 21 de TL
        J = J + 1 'incrémente J (ajoute une colonne à TL
        CS.Close SaveChanges:=False 'ferme le classeur source sans enregistrer
        F = Dir 'passe au prochain fichier du dossier
    End If 'fin de la condition 1
Loop 'boucle
If J = 1 Then Exit Sub 'si J=1, sort de la procédure
'renvoie dans la celllue A3 redimensionnée de l'onglet OD, le tableau TL tranposé
OD.Range("A3").Resize(UBound(TL, 2), UBound(TL, 1)).Value = Application.Transpose(TL)
Application.ScreenUpdating = True 'afficheles rafraîchissements d'écran
End Sub
Natou_v01.xlsm
(28.72 Kio) Téléchargé 35 fois
À plus,

ThauTheme


Je suis Charlie
VBA m'éclate, les formules m'ennuient ! Je n'y peux rien c'est comme ça...
n
natou131
Jeune membre
Jeune membre
Messages : 32
Inscrit le : 11 mars 2011
Version d'Excel : 2003

Message par natou131 » 12 mai 2015, 10:23

Bonjour,

Merci à vous, la 1ère solution me semble marcher (je finis mes tests) et correspond bien à notre besoin.

Merci beaucoup !!

Natacha
Avatar du membre
fred2406
Membre impliqué
Membre impliqué
Messages : 2'090
Appréciations reçues : 39
Inscrit le : 13 mai 2014
Version d'Excel : O365Pro-2019-2011MAC
Version de Calc : 6.3

Message par fred2406 » 12 mai 2015, 19:51

SI la solution convient
:btres:
merci
Fred
Je ne réponds pas aux M.P. non sollicités.
Ne pas oublier :
:btres:
Fred :O-O:
Répondre Sujet précédentSujet suivant
  • Sujets similaires
    Réponses
    Vues
    Dernier message