XL 2019 Récupération sur fichier unique suite à questionnaires (VBA)

Julie-F

XLDnaute Occasionnel
Bonjour à tous,

J'aurai besoin de vos lumières pour me permettre de récupérer sur un fichier via une macro commande, les résultats de x questionnaires.

Dans un même répertoire se trouvent x fichiers aux noms différents mais tous constitués sur le même format, à savoir 2 onglets :
1er onglet = questionnaire
2e onglet = DONNEES 1 qui reprend l'ensemble des réponses apportées au questionnaire

On retrouve également dans ce répertoire, un fichier nommé "BILAN"

C'est dans ce fichier que je voudrais récupérer automatiquement chaque ligne de chaque fichier questionnaire du 2e onglet "DONNEES 1" sans être obligée d'ouvrir chacun d'eux et ressaisir/recopier l'ensemble des réponses.

Je vous remercie pour toute l'aide que vous pourrez m'apporter
 

Pièces jointes

  • BILAN.xlsx
    9.4 KB · Affichages: 1
  • QUESTIONNAIRE.xlsx
    11.9 KB · Affichages: 3
Dernière édition:

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour Julie,
Un essai en PJ avec cette macro.
J'ai rajouté pour les test le nom du fichier source en colonne A ( à supprimer ensuite )
VB:
Sub BoucleFichiers()
    Dim Chemin$, Fichier$, Ligne%
    Application.ScreenUpdating = False
    Chemin = ThisWorkbook.Path & "\"
    Ligne = 3
    [A3:BT1000].ClearContents
    Fichier = Dir(Chemin & "*.xls*")                                    'Boucle sur tous les fichiers xls du répertoire.
    Do While Len(Fichier) > 0
        If Left(Fichier, 5) <> "BILAN" Then                             ' Sauf fichier Bilan
            Workbooks.Open Chemin & Fichier
            T = Sheets("DONNEES 1").[B3:BT3]                            ' On récupère les données ligne 3
            ActiveWorkbook.Close Savechanges:=False
            Cells(Ligne, "A") = Split(Fichier, ".")(0)                  ' On récupère le nom du fichier
            Cells(Ligne, "B").Resize(UBound(T, 1), UBound(T, 2)) = T    ' On restitue les données
            Ligne = Ligne + 1                                           ' Fichier suivant
        End If
        Fichier = Dir()
    Loop
End Sub
 

Pièces jointes

  • BILAN.xlsm
    16.7 KB · Affichages: 2

Julie-F

XLDnaute Occasionnel
Bonsoir Sylvanu

Merci beaucoup pour ton aide et ta proposition particulièrement claire et fort pédagogique 😍
Cela va me faciliter grandement la compilation des questionnaires retournés.... Aussi à nouveau, un grand MERCI ...

Bonne soirée à toi
 

Statistiques des forums

Discussions
313 296
Messages
2 096 922
Membres
106 787
dernier inscrit
Rachid ALIOU