Création d'une base de données à partir de 7 fichiers

Question

Je vous contacte par manque d'expérience en VBA , j'ai un objectif qui serait le suivant ==&gt; créer une macro qui permette d'extraire les données des 7 fichiers suivants afin de créer une base de données unique, ci-dessous les 7 fichiers concernés et leur racine : En gros, il devra y avoir un fichier supplémentaire unique "SUIVI DES FA - KPI" qui aura logiquement 2 feuilles (la premiere ou on vient extraire toutes les données), la deuxième où l'on met en place des graphiques/indicateurs en exploitant la base de données de la première : C'est logiquement sur ce dernier fichier "SUIVI DES FA - KPI" que devra être la macro qui récupère toute la data des 7 autres fichiers. Á noter que ces 7 fichiers sont protégés par des mots de passe afin de pereniser leurs recensement... Mais sur le fichier "SUIVI DES FA - KPI", j'aimerais si cela est faisable que suite à l'activation de la macro et à la récupération de la DATA, la feuille en question ne soit pas protégée et donc modifiable sans blocage afin de faciliter la deuxième partie ou je devrais analyser ces données par graphique, etc... Pour ce qui est de la DATA : ce qui m'intéresse se situe dans les onglets RECENSEMENT de chacun des 7 fichiers. En gros il faut d'abord coller les titres de colonnes à savoir B4:T5 en valeur + format. Puis en dessous de ces titres de colonne, venir coller en valeur + format toutes les lignes (de la colonne B à la colonne T) non vides de chacun des 7 fichiers (je n'ai pas d'ordre de préférence pour le collage des lignes). Je ne sais pas si cela est faisable mais ça serait super si la macro du fichier "SUIVI DES FA - KPI" lorsqu'elle est lancée une deuxième fois, vienne supprimer toute la data présente pour recommencer l'extraction. Si je demande cela, c'est qu'il est possible que les utilisateurs des 7 fichiers viennent corriger des informations et cela même sur les premières lignes de chacun des 7 fichiers. Les 7 fichiers sont trop lourds pour que je vous les envoie (macro + requête SQL etc...), j'ai donc créé une version réduite du "SUIVI DES FICHES D'ANOMALIE - CRST" afin que vous puissez voir sa forme et je vous envoie le fichier sur lequel la macro devrait être lancer : En esperant avoir été clair dans ma demande et en esperant qu'elle soit réalisable Bon dimanche ! Charles CARON...

ThauThème · Accepted Answer

Bonjour Charles, bonjour le forum,

Chaque fois que tu lanceras la macro, les anciennes données seront-elles effacées ou faudra-t-il rajouter les nouvelle données à la suite ? Si chaque fichier a un mot de passe unique il faudra nous les fournir tous...

ThauThème · Accepted Answer

Re,

Pas sûr que l'on puisse copier/coller des données protégées. Au pire il suffira de rajouter une ligne de code pour déprotéger. Ci-dessous le code non testé à placer dans un module standard du classeur SUIVI DES FA - KPI:

Sub Macro1()
Dim TB As Variant 'déclare la variable TB (TaBleau)
Dim CAS As String 'déclare la variable CAS (Chemin d'Accès Source)
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim DLS As Long 'déclare la variable DLS (Dernière Ligne Source)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
Dim I As Byte 'déclare la variable I (Incrément)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
TB = Array("CTRL", "DEB", "DG1", "DG2", "DG3", "FG") 'définit le tableau TB
CAS = "T:\SERVICE QUALITÉ\Avis d'Anomalie\" 'définit le chemin d'accès des fichiers source (à adapter si c'est pas bon !)
Set CD = ThisWorkbook 'définit le classeur destination CD
Set OD = CD.Worksheets("DATA") 'définit l'onglet destination OD
If OD.Range("A2").Value <> "" Then OD.Range("A1").CurrentRegion.Offset(1, 0).Clear 'efface les éventuelles anciennes données

'classeur 1
Set CS = Workbooks.Open(CAS & "SUIVI DES FICHES D'ANOMALIE - CRST.xlsm") 'définit le classeur source CS en l'ouvrant
Set OS = CS.Worksheets("RECENSEMENT") 'définit l'onglet source OS
OS.Rows(5).Copy 'copie la ligne 5 de l'onglet source
With OS.Range("A1") 'prend en compte la cellule A1 de l'onglet destination
    .PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False 'copie la largeur des colonnes
    .PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False 'copie les nombres et leur formats
    .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False 'copie les formats
End With 'fin de la prise en compte de la cellule A1
DLS = OS.Cells(Application.Rows.Count, "B").End(xlUp).Row 'définit la dernière ligne éditée de la colonne B de l'onglet source
OS.Range("B6:T" & DLS).Copy 'copie la plage éditée de l'onglet source
Set DEST = OD.Cells(Application.Rows.Count, "A").End(xlUp).Offset(1, 0) 'définit la celllue de destination DEST
With DEST 'prends en compte la cellule de destination DEST
    .PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False 'copie les nombres et leur formats
    .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False 'copie les formats
End With 'fin de la prise en compre de la cellule de destination DEST
CS.Close False 'ferme le classeur source sans enregistrer

'6 autres classeurs
For I = 1 To 6 'boucle sur les 6 valeurs I du tableau TB
    Set CS = Workbooks.Open(CAS & "SUIVI DES FICHES D'ANOMALIE - " & TB(I) & ".xlsm") 'définit le classeur source CS en l'ouvrant
    Set OS = CS.Worksheets("RECENSEMENT") 'définit l'onglet source OS
    DLS = OS.Cells(Application.Rows.Count, "A").End(xlUp).Row 'définit la dernière ligne éditée de la colonne A de l'onglet source
    OS.Range("B6:T" & DLS).Copy 'copie la plage éditée de l'onglet source
    Set DEST = OD.Cells(Application.Rows.Count, "A").End(xlUp).Offset(1, 0) 'définit la celllue de destination DEST
    With DEST 'prends en compte la cellule de destination DEST
        .PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
            xlNone, SkipBlanks:=False, Transpose:=False 'copie les nombres et leur formats
        .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False 'copie les formats
    End With 'fin de la prise en compre de la cellule de destination DEST
    CS.Close False 'ferme le classeur source sans enregistrer
Next I 'prochaine valeur du tableau TB
ThisWorkbook.Save 'sauve le classeur
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub

JFL · Accepted Answer

Un début de proposition via Power Query. Renseigner le chemin du répertoire et actualiser le tout. Remarque : Pour tester cette proposition j'ai dédoublé le fichier source suivi des anomalies..... ne pas s'inquiéter des doublons dans le retour ...

ThauThème · Accepted Answer

Bonsoir le fil, bonsoir le forum,

J'ai pu copier la première ligne grâce au fichier de JFL, que je remercie car j'avais la flemme de tout taper, et cela simplifie considérablement le code. Si il faut déprotéger, il te faut juste adapter les lignes :

OS.Unprotect "toto"

et

OS.Protect "toto"

Le fichier :

21suivi-des-fa-kpi-1.xlsm (20.45 Ko)

JFL · Accepted Answer

Vos images laissent à penser que vos 7 fichiers sont logés dans un même répertoire...... Visiblement ce n'est pas le cas..... On peut construire une table qui servira de base à Power Query. Le chemin de vos différents fichiers peut-il être construit (selon quelle logique ?) ou l'emplacement devra être saisi manuellement ...

JFL · Accepted Answer

Dans le fichier proposé, une feuille nommée "Paramètres PQ" sert à recueillir l'emplacement du répertoire. Vous remplacez la valeur de la cellule C1 par l'emplacement de votre répertoire et ensuite vous pouvez lancer l’actualisation...

JFL · Accepted Answer

Bravo pour cette solution apportée à votre besoin ! Concernant le VBA, je passe la main aux virtuoses.......