Microsoft 365 extraction de données vba

Bob 31 · 10 Mars 2024

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

job75 · 15 Mars 2024

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

VB:

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...

Bob 31 · 12 Mars 2024

Oui d'accord
Mais j'ai un dossier général (drh) puis des sous dossiers par agents (ABADIE FABIEN) et dans chacun de ces sous dossiers j'ai des classeurs nommé par Nom Penon Année (ABADIE FABIEN 2024) est il de permettre une extraction par année mais pour l'ensemble des agents que j'aurai renseigné sur la colonne A du classeur cible (AMPLITUDES)
Merci

job75 · 12 Mars 2024

Bob 31 à dit:
Mais j'ai un dossier général (drh) puis des sous dossiers par agents

C'est pourquoi la macro ouvre une boîte de dialogue.

Bob 31 · 12 Mars 2024

D’accord
Mais je n’arrive pas à l’ouvrir

job75 · 12 Mars 2024

La macro l'ouvre par l'instruction :

VB:

fichier = Application.GetOpenFilename("Fichiers .xlsx (*.xlsx), *.xlsx")

Cette instruction fonctionne sur Windows mais pas sur MAC.

Bob 31 · 12 Mars 2024

Oui mais je n’arrive pas à indiquer le chemin

job75 · 12 Mars 2024

La macro calcule elle-même le chemin :

VB:

chemin = Left(fichier, InStrRev(fichier, "\"))

Bob 31 · 12 Mars 2024

Mais cela ne fonctionne pas

job75 · 12 Mars 2024

Bien sûr que si.

Mais vous n'avez pas compris que la boîte de dialogue sert à sélectionner l'un des fichiers situés dans le dossier où il se trouve !

Je ne peux pas faire plus pour vous, c'est à vous de comprendre.

Bob 31 · 12 Mars 2024

Je penses que je me suis mal exprimé
Ce que je souhaiterai c’est que quand j’ouvre le classeur cible celui ci mette à jour l’extraction des données de l’ensemble des agents que j’aurais renseigné en colonne A depuis l’ensemble des classeurs de chaque agents

job75 · 12 Mars 2024

Je me suis bien exprimé et je n'en ferai pas plus.

Dranreb · 12 Mars 2024

Bonsoir.
Essayez un code de ce genre peut être :

VB:

Sub Test()
   Dim RngCbl As Range, Année As String, T(), L&, Wbk As Workbook, C%
   Set RngCbl = ActiveSheet.Cells(1, "A").CurrentRegion
   Set RngCbl = RngCbl.Resize(RngCbl.Rows.Count - 1)
   T = RngCbl.Value
   Année = ActiveSheet.Name
   For L = 2 To UBound(T, 1)
      Set Wbk = Workbooks.Open("\\192.168.0.250\shared\drh\" & T(L, 1) & "\" & T(L, 1) & " " & Année & ".xlsx")
      For C = 2 To 13
         T(L, C) = Wbk.Worksheets(T(1, C)).Cells(43, "G").Value
         Next C
      Wbk.Close SaveChanges:=False
      Next L
   RngCbl.Value = T
   End Sub

À étoffer d'un On Error Resume Next au début et surtout de contrôles divers (fichier inexistant, onglets noms de mois avec blanc en trop etc…)

job75 · 12 Mars 2024

Ah mais je n'avais pas vu que vous avez créé un dossier pour chaque agent.

Pour que ma macro fonctionne il faut un dossier par année.

Donc au lieu de :

\\192.168.0.250\shared\drh\" & NomPré & "\" & NomPré & " " & Année & ".xlsx"

îl faut :

\\192.168.0.250\shared\drh\" & Année & "\" & NomPré & " " & Année & ".xlsx"

Bob 31 · 12 Mars 2024

Ci joint le classeur cible

Bob 31 · 13 Mars 2024

Bonjour,

J'ai essayé avec une autre formule mais je n'arrive pas à modifier la programmation
Le problème est que l’extraction reprend le chemin ci-dessous mais me met les apostrophes avant et après la cellule voulue et ce sont ces apostrophes qui empêchent d’obtenir le résultat
='\\192.168.0.250\drh\ABADIE FABIEN\[ABADIE FABIEN 2024.xlsx]JANVIER'!'G43'

Private Sub Workbook_Open()
' Const Année = "2022"
Dim Année As String, L&, NomPré
Année = Cells(1, "Z").Value ' À VÉRIFIER (je n'avais vu qu'après que l'année était dans une cellule)
L = 2
Do: NomPré = Cells(L, "A").Value: If VarType(NomPré) <> vbString Then Exit Do
If Dir("\\192.168.0.250\drh\" & NomPré & "\" & NomPré & " " & Année & ".xlsx") = "" Then
Cells(L, "B").Resize(1, 1).Value = CVErr(xlErrRef)
Else
Cells(L, "B").Resize(1, 1).FormulaR1C1 = "='\\192.168.0.250\drh\" & NomPré _
& "\[" & NomPré & " " & Année & ".xlsx]JANVIER'!G43"
Cells(L, "C").Resize(1, 1).FormulaR1C1 = "='\\192.168.0.250\drh\" & NomPré _
& "\[" & NomPré & " " & Année & ".xlsx]FEVRIER'!G43"
End If
L = L + 1
Loop
End Sub

Je ne trouve pas la solution pour régler cela
En vous remerciant

job75 · 14 Mars 2024

Bonsoir Bob 31, le forum,

On ne pouvait pas se quitter comme ça.

J'ai revu le problème en mettant les fichiers .xlsx dans les dossiers Nom Prénom.

Téléchargez le dossier zippé joint et faites l'extraction dans le dossier que vous voulez.

Puis exécutez cette nouvelle macro :

VB:

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
'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
            lig = lig + 1
        End If
Next f, dossier
'---compléments---
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) = "=AVERAGE(R2C:R" & lig - 1 & "C)"
P.EntireColumn.AutoFit 'ajustement largeurs
End Sub

Il vaut mieux utiliser le chemin ThisWorkbook.Path & "\" c'est plus facile à tester.

Je rappelle :
- pas d'accents dans les noms des mois
- pas d'espaces superflus dans les noms des feuilles.

A+

Microsoft 365 extraction de données vba

Bob 31

XLDnaute Occasionnel

job75

Bob 31

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

Bob 31

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

Bob 31

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

Bob 31

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

Bob 31

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

Dranreb

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Bob 31

XLDnaute Occasionnel

Pièces jointes

Bob 31

XLDnaute Occasionnel

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

Discussions similaires