Microsoft 365 extraction de données vba

[Bob 31]

Bonjour,
je souhaite extraire depuis une trentaine de classeurs vers un classeur les données de personnes depuis une cellule pour chaque mois de l'année
Ces données me serviraient a calculer les moyennes mensuelles et également des moyennes au fil des mois de l'année pour chacune des personnes
En vous remerciant par avance pour votre aide

 

[Bob 31]

Bonsoir job 75
Super merci pour votre aide
Cela fonctionne pour les mois de Janvier et février mais pas sur les 10 autres mois
Est il possible d'extraire que les données des agents renseignes dans la feuille "SANITAIRE" du classeur amplitudes
Merci encore

 

[Bob 31]

Ci joint classeur

 

[job75]

Bonjour Bob 31, le forum,

Cela fonctionne pour les mois de Janvier et février mais pas sur les 10 autres mois

Pour les autres mois la cellule G43 est nulle, dans le fichier AMPLITUDES il suffit de supprimer les valeurs zéro et de modifier les formules calculant les moyennes.

Est il possible d'extraire que les données des agents renseignes dans la feuille "SANITAIRE" du classeur amplitudes

Ce n'est pas une bonne idée car la macro traite tous les fichiers .xlsx de l'année étudiée.

A+

 

[job75]

1) Par ailleurs on peut automatiser l'exécution de la macro Liste_Fichiers en plaçant dans ThisWorkbook :

Private Sub Workbook_Activate()
Liste_Fichiers
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Liste_Fichiers
End Sub

2) J'ai légèrement modifié la macro :

Sub Liste_Fichiers()
Dim annee$, chemin$, P As Range, fso As Object, lig&, dossier As Object, f As Object, fichier$, x$, col%
annee = ActiveSheet.Name
If Not annee Like "####" Then Exit Sub 'ne traite pas les autres feuilles
'chemin = "\\192.168.0.250\shared\drh\"
chemin = ThisWorkbook.Path & "\" 'plus facile pour tester
Set P = ActiveSheet.ListObjects(1).Range 'tableau structuré
Application.ScreenUpdating = False
P(2, 1).Resize(, 13) = ""
Rows(P.Rows(3).Row & ":" & Rows.Count).Delete 'RAZ en dessous
Set fso = CreateObject("Scripting.FileSystemObject")
lig = 2
For Each dossier In fso.GetFolder(chemin).SubFolders
    For Each f In dossier.Files
        fichier = dossier.Name & " " & annee & ".xlsx"
        If f.Name = fichier Then
            P(lig, 1) = dossier.Name
            x = "'" & chemin & dossier.Name & "\[" & fichier & "]"
            For col = 2 To 13
                P(lig, col) = ExecuteExcel4Macro(x & P(1, col) & "'!R43C7") 'cellule G43
            Next col
            P(lig, 2).Resize(, 12).Replace 0, "", xlWhole 'supprime les valeurs zéro
            lig = lig + 1
        End If
Next f, dossier
'---compléments---
If lig = 2 Then lig = 3 'si le tableau est vide
P(lig + 1, 1) = "TOTAL"
P(lig + 1, 2).Resize(, 24) = "=SUM(R2C:R" & lig - 1 & "C)"
P(lig + 2, 1) = "MOYENNE MENSUELLE"
P(lig + 2, 2).Resize(, 12) = "=IFERROR(AVERAGE(R2C:R" & lig - 1 & "C),"""")"
P.EntireColumn.AutoFit 'ajustement largeurs
End Sub

3) Dans les feuilles 2024 et 2025 formule en N2 à tirer vers la droite :

=SIERREUR(MOYENNE($B2:B2);"")

 

[Bob 31]

Bonjour Job75
J'ai renseigné les autres mois et cela fonctionne bien
Pour la moyenne individuelle oui il faut bien rectifier car le calcul commence en colonne N avec N1
L'extraction que les données des agents renseignes dans la feuil2 "SANITAIRE" du classeur amplitudes m'aurait bien aidé car dans le dossier j'ai une autre trentaine d'agent et donc de fichiers .xlsx qui ne sont pas concerné par cette amplitude

 

[job75]

Les formules en N2:Y2 ne se maintenaient pas correctement, il faut les faire entrer par la macro :

'---compléments---
P(2, 14).Resize(, 12) = "=IFERROR(AVERAGE($B2:B2),"""")" 'formules en N2:Y2
If lig = 2 Then lig = 3 'si le tableau est vide
P(lig + 1, 1) = "TOTAL"
P(lig + 1, 2).Resize(, 24) = "=SUM(R2C:R" & lig - 1 & "C)"
P(lig + 2, 1) = "MOYENNE MENSUELLE"
P(lig + 2, 2).Resize(, 12) = "=IFERROR(AVERAGE(R2C:R" & lig - 1 & "C),"""")"
P.EntireColumn.AutoFit 'ajustement largeurs
End Sub

 

[job75]

L'extraction que les données des agents renseignes dans la feuil2 "SANITAIRE" du classeur amplitudes m'aurait bien aidé car dans le dossier j'ai une autre trentaine d'agent et donc de fichiers .xlsx qui ne sont pas concerné par cette amplitude

Si vous ne voulez pas que le fichier ABADIE FABIEN 2024 soit listé faites suivre 2024 d'une ou deux lettres par exemple ABADIE FABIEN 2024X ou ABADIE FABIEN 2024NC.

 

[Bob 31]

Très bien, lorsque je met le document dans le dossier cela bloque sur le mois de mars et les suivant je ne comprend pas
Le choix depuis une feuille ou autre pour l'extraction des agents choisis m'arrangerait sinon je devrais faire un tri

 

[Bob 31]

Renommer le fichier de base n'est pas possible car j'utilise c'est fichier pour d'autres exports

 

[job75]

Renommer le fichier de base n'est pas possible car j'utilise c'est fichier pour d'autres exports

Bah mettez les fichiers que vous ne voulez pas traiter dans un autre sous-dossier nommé "EXCLUS".

Si ensuite il faut les traiter prévoyez une autre macro.

 

[Bob 31]

De les dissocier avec un sous dossier me complique également, car pour certaines extinctions, je dois prendre tous les classeurs
Concernant l’extraction de mars À décembre, cela fonctionne sur exemple, mais lorsque je mets le classeur le dossier concerné pas d’extraction de mars à décembre

 

[job75]

Concernant l’extraction de mars À décembre, cela fonctionne sur exemple, mais lorsque je mets le classeur le dossier concerné pas d’extraction de mars à décembre

J'ai dit et je répète : pas d'espaces superflus dans les noms des feuilles !!!

 

[job75]

Maintenant pour traiter uniquement les dossiers listés dans la feuille SANITAIRE utilisez cette macro :

Sub Liste_Fichiers()
Dim annee$, chemin$, P As Range, fso As Object, lig&, dossier As Object, f As Object, fichier$, x$, col%
annee = ActiveSheet.Name
If Not annee Like "####" Then Exit Sub 'ne traite pas les autres feuilles
'chemin = "\\192.168.0.250\shared\drh\"
chemin = ThisWorkbook.Path & "\" 'plus facile pour tester
Set P = ActiveSheet.ListObjects(1).Range 'tableau structuré
Application.ScreenUpdating = False
P.Rows(2) = "" 'efface toute la ligne
Rows(P.Rows(3).Row & ":" & Rows.Count).Delete 'RAZ en dessous
Set fso = CreateObject("Scripting.FileSystemObject")
lig = 2
For Each dossier In fso.GetFolder(chemin).SubFolders
    If Application.CountIf(Sheets("SANITAIRE").Columns(1), dossier.Name) Then
        For Each f In dossier.Files
            fichier = dossier.Name & " " & annee & ".xlsx"
            If f.Name = fichier Then
                P(lig, 1) = dossier.Name
                x = "'" & chemin & dossier.Name & "\[" & fichier & "]"
                For col = 2 To 13
                    P(lig, col) = ExecuteExcel4Macro(x & P(1, col) & "'!R43C7") 'cellule G43
                Next col
                P(lig, 2).Resize(, 12).Replace 0, "", xlWhole 'supprime les valeurs zéro
                lig = lig + 1
            End If
        Next f
    End If
Next dossier
'---compléments---
P(2, 14).Resize(, 12) = "=IFERROR(AVERAGE($B2:B2),"""")" 'formules en N2:Y2
If lig = 2 Then lig = 3 'si le tableau est vide
P(lig + 1, 1) = "TOTAL"
P(lig + 1, 2).Resize(, 24) = "=SUM(R2C:R" & lig - 1 & "C)"
P(lig + 2, 1) = "MOYENNE MENSUELLE"
P(lig + 2, 2).Resize(, 12) = "=IFERROR(AVERAGE(R2C:R" & lig - 1 & "C),"""")"
P.EntireColumn.AutoFit 'ajustement largeurs
End Sub

 

[merinos-BernardEtang]

Bon je laisse tomber : tu ne dis pas laquelle qui se reproduira probablement en VBA si toutefois un VBiste se décide à te répondre...
Bonne continuation

Salut Chris,

Microsoft se démène pour créer un outil d'extraction et de transformation de données.

PowerQuery est juste GENIAL...

Mais certains préfèrent la spéléologie, avec lampe frontale, cordes de rappel et tout le toin-toin...

Visiblement ils sont toujours occupés à explorer les cavernes...

Bonne journée,

Merinos

 

[Bob 31]

Merci Job75
Trop cool
Parfait