Microsoft 365 Récupérer la data de plusieurs feuille

[driss Kor]

Bonjour

Je souhaite avec le VBA sur le fichier ci-joint récupérer le % Rate et paie en vérifiant chaque feuille avec comme critère de recherche le ID

D'avance Merci pour votre aide.

 

[sylvanu]

Bonjour Driss,
Il est où le ficher joint ? 🙂

 

[job75]

Bonjour driss Kor, sylvanu,

Voyez le fichier joint et cette fonction VBA :

Function TrouveValeur(lig, ref As Range)
Application.Volatile
Dim w As Worksheet, c As Range
On Error Resume Next
Set w = Sheets(lig)
Set c = w.Cells.Find(ref, , xlValues)
TrouveValeur = ""
TrouveValeur = c.Offset(, 1)
End Function

Formule en Feuil1!A4 à tirer à droite et vers le bas : =TrouveValeur(LIGNE()-2;A$3)

Edit : pas besoin des variables w et c :

Function TrouveValeur(lig, ref As Range)
Application.Volatile
On Error Resume Next
TrouveValeur = ""
TrouveValeur = Sheets(lig).Cells.Find(ref, , xlValues).Offset(, 1)
End Function

A+

 

[sylvanu]

Re, bonjour Job,
Dans le même ordre d'idée, un essai en PJ sans formule.
La table se remet à jour automatiquement lorsqu'on sélectionne la feuille Feuil1. Avec :

Sub Worksheet_Activate()
Dim L%, F
L = 4: [A4:C30].ClearContents
For Each F In Worksheets
    If F.Name <> ActiveSheet.Name Then
        On Error Resume Next
        Cells(L, "A") = Sheets(F.Name).Cells.Find("ID", , xlValues).Offset(, 1)
        Cells(L, "B") = Sheets(F.Name).Cells.Find("% Rate", , xlValues).Offset(, 1)
        Cells(L, "C") = Sheets(F.Name).Cells.Find("Paie", , xlValues).Offset(, 1)
        L = L + 1
    End If
Next F
End Sub

 

[job75]

Ma solution du post #3 est quand même très minimaliste.

Cette fonction va bien quelles que soient les positions des feuilles et seules celles contenant "ID" sont étudiées :

Function TrouveValeur(lig&, ref As Range)
Application.Volatile
Dim nomfeuille$, w As Worksheet, c As Range, n&, nf$
nomfeuille = Application.Caller.Parent.Name
For Each w In Worksheets
    If w.Name <> nomfeuille Then
        Set c = w.Cells.Find("ID", , xlValues, xlWhole)
        If Not c Is Nothing Then n = n + 1: If n = lig Then nf = w.Name: Exit For
    End If
Next
On Error Resume Next
TrouveValeur = ""
TrouveValeur = Sheets(nf).Cells.Find(ref, , xlValues, xlWhole).Offset(, 1)
End Function

 

[sylvanu]

Bonsoir Job,
Le souci d'une telle fonction est que si l'utilisateur change la feuille de place ou en ajoute une avant alors les résultats sont incorrectes.
De plus à chaque modification de valeur dans une quelconque fois tout le tableau sera réactualisé.
Deux soucis qu'on évite avec un Worksheet_Activate.

 

[job75]

Le souci d'une telle fonction est que si l'utilisateur change la feuille de place ou en ajoute une avant alors les résultats sont incorrectes.

Pas du tout, avec la fonction du post #5 aucun problème, j'ai bien dit "quelles que soient les positions des feuilles".

De plus à chaque modification de valeur dans une quelconque fois tout le tableau sera réactualisé.

Heureusement !

 

[job75]

Bonjour le forum,

Sur le fichier du post #5 les 24 formules se recalculent chez moi en 43 millisecondes.

Avec ce code il n'y a plus qu'une seule formule qui se recalcule en 8 millisecondes :

'---constantes mémorisées---
Const ref1$ = "ID"
Const ref2$ = "% Rate"
Const ref3$ = "Paie"
Const ligref% = 3

Function TrouveValeur()
Application.Volatile
Dim nomfeuille$, nlig&, a(), i&, j%, w As Worksheet, c As Range, n&, lig&
nomfeuille = Application.Caller.Parent.Name
nlig = Application.Caller.Rows.Count
ReDim a(1 To nlig, 1 To 3)
For i = 1 To nlig: For j = 1 To 3: a(i, j) = "": Next j, i
For Each w In Worksheets
    If w.Name <> nomfeuille Then
        Set c = w.Cells.Find(ref1, , xlValues, xlWhole)
        If Not c Is Nothing Then
            n = n + 1
            For lig = 1 To nlig
                If n = lig Then
                    a(n, 1) = c.Offset(, 1)
                    On Error Resume Next
                    a(n, 2) = w.Cells.Find(ref2).Offset(, 1)
                    a(n, 3) = w.Cells.Find(ref3).Offset(, 1)
                End If
            Next lig
        End If
    End If
Next w
TrouveValeur = a 'matrice
End Function

La fonction est matricielle, chez moi sur Excel 2019 il faut valider en bloc la plage A4:C11 par Ctrl+Maj+Entrée.

A+

 

[job75]

Pour tester j'ai ajouté 100 feuilles vierges dans le fichier, la fonction se recalcule en 10 millisecondes.

Avec le même fichier j'ai testé la macro du post #4 de sylvanu, elle s'exécute en 39 millisecondes.

En ajoutant Application.ScreenUpdating = False on passe à 25 millisecondes.

 

[driss Kor]

Désolé pour la réponse tardive,
Merci beaucoup pour tout le monde votre aide été précieuse.

 

[job75]

Bonjour driss Kor,

Vous avez coché comme solution votre post #10, ce n'est pas une chose normale car vous n'avez rien trouvé.

Merci de cocher le post qui selon vous répond le mieux au problème que vous avez posé.

A+