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]

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]

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]

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

 

[job75]

La macro l'ouvre par l'instruction :

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

Cette instruction fonctionne sur Windows mais pas sur MAC.

 

[Bob 31]

Oui mais je n’arrive pas à indiquer le chemin

 

[job75]

La macro calcule elle-même le chemin :

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

 

[Bob 31]

Mais cela ne fonctionne pas

 

[job75]

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]

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]

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

 

[Dranreb]

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

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]

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]

Ci joint le classeur cible

 

[Bob 31]

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]

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 :

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+