Compléter plusieurs tableaux au départ d'un seul tableau

Bonjour à toutes et à tous,

J'aimerais faire quelque chose mais n'ai aucune idée de si c’est réalisable ou pas et surtout de comment faire... J'ai bien vu quelques idées sur le forum avec notamment la fonction RECHERCHE mais n'ai aucune idée de comment faire...

Voilà ma demande :

Je dispose d'un fichier avec 5 feuilles : une feuille BD de travail, une feuille Services et trois feuilles de Pôles d'activités.

Dans ma première feuille se trouvent une liste de personnes et leur attribution d'activités pour la semaine. Chaque jour est séparé en 2 : matin et après-midi.

J'aimerais que les tableaux des 3 feuilles de pôles se remplissent automatiquement en fonction de la feuille BD de travail comme dans le premier tableau de la feuille Pôle Arts et culture...

Comment puis-je réaliser cela ?

D'avance, merci pour votre aide

Bonjour

Un essai à tester. Te convient-il ?

Bye !

Bonjour à tous,

Une autre façon de procéder via un dictionnaire

Pour établir une correspondance, il faut que le nom des activités figurant en feuille "BD de travail" soit identique aux différents en-têtes figurant en feuilles "Pôles"

Attention aux espaces parasites en bout de chaînes de caractères

Option Explicit
Sub ventile()
Dim a, w(), x(), e, i As Long, j As Long, n As Long
Dim dico As Object, dico1 As Object, ws As Worksheet, r As Range
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    Set dico1 = CreateObject("Scripting.Dictionary")
    dico1.CompareMode = 1
    a = Sheets("BD de travail").Range("a1").CurrentRegion.Value
    n = 1
    For j = 9 To UBound(a, 2) - 1
        n = n + 1
        dico(a(1, j)) = n
    Next
    For i = 2 To UBound(a, 1)
        For j = 9 To UBound(a, 2) - 1
            If Not IsEmpty(a(i, j)) Then
                If Not dico1.exists(a(i, j)) Then
                    ReDim w(1 To 2): ReDim x(1 To 15, 1 To 11)
                    Set w(1) = CreateObject("Scripting.Dictionary")
                    w(1).CompareMode = 1
                    w(2) = x
                    dico1(a(i, j)) = w
                End If
                w = dico1(a(i, j))
                x = w(2)
                If Not w(1).exists(a(i, 3)) Then
                    w(1)(a(i, 3)) = w(1).Count + 1
                    x(w(1)(a(i, 3)), 1) = a(i, 3)
                End If
                x(w(1)(a(i, 3)), dico(a(1, j))) = "x"
                w(2) = x
                dico1(a(i, j)) = w
            End If
        Next
    Next
    Application.ScreenUpdating = False
    For Each ws In Worksheets([{"Pôle Arts & culture","Pôle Production & services","Pôle Sport, bien-être & loisirs"}])
        Sheets(ws.Name).Range("3:17,20:34,37:51").ClearContents
        For Each e In dico1.keys
            Set r = Sheets(ws.Name).Cells.Find(e, lookat:=xlWhole)
            If Not r Is Nothing Then
                With r.Offset(2, -1)
                    With .Resize(dico1.Item(e)(1).Count, 11)
                        .Value = dico1.Item(e)(2)
                    End With
                End With
            End If
        Next
    Next
    Set dico = Nothing: Set dico1 = Nothing
    Application.ScreenUpdating = True
End Sub

klin89

gmb a écrit :

Bonjour

Un essai à tester. Te convient-il ?

Bye !

Super !

Puis-je savoir comment tu as procédé ?

Bien à toi

Merci !

re Bossinet,

Le code réajusté, toutes les correspondances sont établies.

Option Explicit
Sub ventile()
Dim a, w(), x(), e, i As Long, j As Long, n As Long
Dim dico As Object, dico1 As Object, ws As Worksheet, r As Range
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    Set dico1 = CreateObject("Scripting.Dictionary")
    dico1.CompareMode = 1
    a = Sheets("BD de travail").Range("a1").CurrentRegion.Value
    n = 1
    For j = 9 To UBound(a, 2) - 1
        n = n + 1
        dico(a(1, j)) = n
    Next
    For i = 2 To UBound(a, 1)
        For j = 9 To UBound(a, 2) - 1
            If Not IsEmpty(a(i, j)) Then
                If Not dico1.Exists(a(i, j)) Then
                    ReDim w(1 To 2): ReDim x(1 To 15, 1 To 11)
                    Set w(1) = CreateObject("Scripting.Dictionary")
                    w(1).CompareMode = 1
                    w(2) = x
                    dico1(a(i, j)) = w
                End If
                w = dico1(a(i, j))
                x = w(2)
                If Not w(1).Exists(a(i, 3)) Then
                    w(1)(a(i, 3)) = w(1).Count + 1
                    x(w(1)(a(i, 3)), 1) = a(i, 3)
                End If
                x(w(1)(a(i, 3)), dico(a(1, j))) = "x"
                w(2) = x
                dico1(a(i, j)) = w
            End If
        Next
    Next
    For Each e In Array(Array("PDS", "Parcours des sens"), _
                        Array("Sophro", "Sophrologie"), _
                        Array("Comm.-terre", "Communau-terre"), _
                        Array("GA & animaux", "Grand air et animaux"), _
                        Array("Act. Phy.", "Activités physiques"), _
                        Array("RP", "Rythmes pluriels"))
        If dico1.Exists(e(0)) Then
            dico1.Key(e(0)) = e(1)
        End If
    Next
    Application.ScreenUpdating = False
    For Each ws In Worksheets _
        ([{"Pôle Arts & culture","Pôle Production & services","Pôle Sport, bien-être & loisirs"}])
        Sheets(ws.Name).Range("3:17,20:34,37:51").ClearContents
    Next
    For Each e In dico1.keys
        For Each ws In Worksheets _
            ([{"Pôle Arts & culture","Pôle Production & services","Pôle Sport, bien-être & loisirs"}])
            Set r = Sheets(ws.Name).Cells.Find(e, lookat:=xlWhole)
            If Not r Is Nothing Then
                With r.Offset(2, -1)
                    With .Resize(dico1.Item(e)(1).Count, 11)
                        .Value = dico1.Item(e)(2)
                    End With
                End With
                Exit For
            End If
        Next
    Next
    Set dico = Nothing: Set dico1 = Nothing
    Application.ScreenUpdating = True
End Sub

Visiblement, cela lui convient

Prend même pas le temps d'analyser le résultat obtenu

klin89

Bonjour,

Tu as déjà reçu des solutions via VBA.

Je me permets de t'en présenter une SANS VBA uniquement avec des fonctions.

Le principe :

1 Détecter les lignes utilisées par un cours grâce aux colonnes AA à AX dans l'onglet BD de travail (ces colonnes peuvent être masquées car uniquement pour usage technique - je les ai laissées apparentes pour que tu comprennes)

2 Lister les noms des profs dans chaque cours Attention : formule matricielle à introduire avec CTRL / MAJ / ENTER

3 Détecter leur présence dans chaque demi jour de la semaine

Si la solution t'intéresse, je veux bien expliquer plus longuement le "comment cela marche" mais je veux d'abord savoir si cela t'intéresse car cela prend beaucoup de temps d'expliquer et j'ai déjà consacrer quelques heures à ton application.

Encore une fois, si cela t'intéresse, il faudrait me dire si les ALI3 à ALI11 sont des erreurs de frappe car je ne les retrouve pas dans tes tableaux et je ne les ai donc pas traités.

Enfin, comme là dit un de mes collègues, il faut que les différents libellés soient parfaitement identiques :

• éviter les espaces parasites en fin de libellés
• ne pas utiliser le libellé en entier à un endroit et une abréviation à un autre

Merci de confirmer ton intérêt ou non.

Quoiqu'il en soit, ton application m'a intéressé

A bientôt j'espère

Chris

Merci Chris45,

Je ne connais pas le VBA et en farfouillant un peu sur le net, j'ai pu activer l'onglet développeur. Du coup, j'ai vu pour le VBA

Mais je n'y comprends rien... Merci toutefois à Gmb et Klin89 pour leur réponse rapide

Par contre ta version avec formules me parle beaucoup plus ! Pour ce qui est des Ali 3 à Ali 11, j'ai fait un copier glisser et il m'a incrémenté l'Ali. Il n'y a donc bien que Ali 1 et Ali 2 comme dans mes tableaux.

Un tout grand merci à tous.

Belle semaine

Bonsoir,

Content que cela te convienne. Comme promis, je t'ai fais un petit mémo pour expliquer comment cela marche.

Je te joins également un mémo qui explique la formule la plus complexe qui est la formule matricielle qui permet de ramener plusieurs lignes répondant au même critère (dans ton cas : tous les enseignants d'un même cours).

J'espère que cela t'aidera.

Si pas clair n'hésites pas à me revenir

Bonne continuation dans Excel

Chris

PS : j'ai mis ton cas dans mon recueil personnel des cas intérressants