Microsoft 365 Reporter automatiquement une liste de noms sur d'autres onglets

Victor21 à dit:

Bonjour, @Coco6985

Si vous sélectionnez plusieurs feuilles en maintenant la touche contrôle (Ctrl) enfoncée -les noms des feuilles sélectionnées changent alors de couleur - toute info entrée sur l'une quelconque des feuilles apparaitra au même endroit (même cellule) sur toutes les feuilles sélectionnées.

Cliquez pour agrandir...

job75 à dit:

Bonsoir Coco6985, Patrick, AL535,

Pour qu'il n'y ait pas de problème avec les formats (les MFC en particulier) j'ai mis le tableau de la feuille Janvier sous forme de tableau structuré.

Voyez le fichier joint et cette macro dans ThisWorkbook :

VB:

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Not IsDate("1/" & Sh.Name) Then Exit Sub
Dim d As Object, P As Range, tablo, i&, x$, source, n&, j%
'---analyse de la feuille du mois---
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Set P = Sh.ListObjects(1).Range
tablo = P.Resize(, 5) 'matrice, plus rapide
For i = 2 To P.Rows.Count - 1
    x = tablo(i, 2)
    If x <> "" And LCase(tablo(i, 1)) = "am" Then If Not d.exists(x) Then d(x) = i 'mémorise la ligne
Next i
'---feuille AGENTS et mise à jour de la feuille du mois---
Application.ScreenUpdating = False
source = Sheets("AGENTS").UsedRange.Resize(, 5) 'matrice, plus rapide
For i = 2 To UBound(source)
    x = source(i, 2)
    If x <> "" And LCase(source(i, 1)) = "am" Then
        If d.exists(x) Then 'mise à jour
            n = d(x)
            For j = 1 To 5
                tablo(n, j) = source(i, j)
                tablo(n + 1, j) = source(i + 1, j)
            Next j
        Else 'crée 2 nouvelles lignes sous le tableau
            If P(2, 1) = "" Then n = 2 Else n = P.Rows.Count + 1 '1ère ligne vide
            For j = 1 To 5
                P(n, j) = source(i, j) 'copie les valeurs
                P(n + 1, j) = source(i + 1, j)
            Next j
            P.Rows(n).Resize(, 5).Font.Color = P(n, 1).Font.Color 'police visible
            P.Rows(n + 1).Borders(xlEdgeBottom).Weight = xlThin 'bordure du bas
            Set P = P.Resize(n + 1)
        End If
    End If
Next i
'---restitution des mises à jour---
P.Resize(UBound(tablo), 5) = tablo
End Sub

Elle s'exécute automatiquement quand on active une feuille de mois (Janvier, Février...).

A+

Cliquez pour agrandir...