Microsoft 365 Transposition de données automatiquement selon critères, c'est possible ?

chris à dit:

RE

La plage Seuil est la cellule nommée en B6 de Plan d''actions

Elle reçoit la valeur choisie pour le filtre

Je l'ai citée en 1ère ligne de mon #4

Cliquez pour agrandir...

job75 à dit:

Bonjour Cherrylie, chris, le forum,

Voyez le fichier joint et ces 2 macros dans le code de la feuille "Plan d'actions" :

VB:

Private Sub Worksheet_Activate()
Worksheet_Change [D6] 'lance la macro
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [D6]) Is Nothing Then Exit Sub
Dim limite, d As Object, P As Range, tablo, i&, x$, nn&, resu(), c As Range, j%, n&, a
[D6].Select
limite = [D6]
'---liste concaténée sans doublon---
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Set P = [A10].CurrentRegion.Resize(, 11) 'colonne K supplémentaire masquée
tablo = P 'matrice, plus rapide
For i = 2 To UBound(tablo)
    x = tablo(i, 1) & tablo(i, 2) & tablo(i, 3) & tablo(i, 4)
    tablo(i, 11) = IIf(d.exists(x) Or tablo(i, 4) <= limite, 1, "") 'repère
    d(x) = i 'mémorise la ligne
Next i
'---analyse du tableau source---
With Sheets("Synthèse des résultats")
    nn = Application.Count(.Range("F16:U" & .Rows.Count))
    If nn = 0 Then GoTo 1
    ReDim resu(nn - 1, 3) 'base 0
    For Each c In .Range("F16:U" & .Rows.Count).SpecialCells(xlCellTypeConstants, 1)
        i = c.Row: j = c.Column
        x = .Cells(i, 3) & .Cells(i, 2) & .Cells(9, j) & c
        If d.exists(x) Then
            d.Remove x 'retire de la liste
        ElseIf c > limite Then
            resu(n, 0) = .Cells(i, 3): resu(n, 1) = .Cells(i, 2)
            resu(n, 2) = .Cells(9, j): resu(n, 3) = c
            n = n + 1
        End If
    Next c
End With
'---reste de la liste---
If d.Count Then
    a = d.items
    For i = 0 To UBound(a)
        tablo(a(i), 11) = 1 'repère
    Next i
End If
'---restitution et mises en forme---
1 Application.ScreenUpdating = False
P.FormatConditions.Delete 'RAZ
P.Columns(11) = Application.Index(tablo, , 11)
If n Then P.Rows(P.Rows.Count + 1).Resize(n, 4) = resu
Set P = P.Resize(P.Rows.Count + n)
P.Borders.Weight = xlThin 'bordures
P.FormatConditions.Add xlExpression, Formula1:="=$K10=1" 'Mise en forme conditionnelle (MFC)
P.FormatConditions(1).Interior.Color = RGB(217, 217, 217) 'gris
End Sub

Elles s'exécutent automatiquement quand on modifie la cellule D6 ou qu'on active la feuille.

Aucune ligne du tableau n'est supprimée, simplement les lignes qui ne répondent plus au critère sont colorées en gris.

A+

Cliquez pour agrandir...

job75 à dit:

Bonjour Cherrylie, chris, le forum,

Voyez le fichier joint et ces 2 macros dans le code de la feuille "Plan d'actions" :

VB:

Private Sub Worksheet_Activate()
Worksheet_Change [D6] 'lance la macro
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [D6]) Is Nothing Then Exit Sub
Dim limite, d As Object, P As Range, tablo, i&, x$, nn&, resu(), c As Range, j%, n&, a
[D6].Select
limite = [D6]
'---liste concaténée sans doublon---
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Set P = [A10].CurrentRegion.Resize(, 11) 'colonne K supplémentaire masquée
tablo = P 'matrice, plus rapide
For i = 2 To UBound(tablo)
    x = tablo(i, 1) & tablo(i, 2) & tablo(i, 3) & tablo(i, 4)
    tablo(i, 11) = IIf(d.exists(x) Or tablo(i, 4) <= limite, 1, "") 'repère
    d(x) = i 'mémorise la ligne
Next i
'---analyse du tableau source---
With Sheets("Synthèse des résultats")
    nn = Application.Count(.Range("F16:U" & .Rows.Count))
    If nn = 0 Then GoTo 1
    ReDim resu(nn - 1, 3) 'base 0
    [COLOR=rgb(251, 160, 38)]For Each c In .Range("F16:U" & .Rows.Count).SpecialCells(xlCellTypeConstants, 1)[/COLOR]
        i = c.Row: j = c.Column
        x = .Cells(i, 3) & .Cells(i, 2) & .Cells(9, j) & c
        If d.exists(x) Then
            d.Remove x 'retire de la liste
        ElseIf c > limite Then
            resu(n, 0) = .Cells(i, 3): resu(n, 1) = .Cells(i, 2)
            resu(n, 2) = .Cells(9, j): resu(n, 3) = c
            n = n + 1
        End If
    Next c
End With
'---reste de la liste---
If d.Count Then
    a = d.items
    For i = 0 To UBound(a)
        tablo(a(i), 11) = 1 'repère
    Next i
End If
'---restitution et mises en forme---
1 Application.ScreenUpdating = False
P.FormatConditions.Delete 'RAZ
P.Columns(11) = Application.Index(tablo, , 11)
If n Then P.Rows(P.Rows.Count + 1).Resize(n, 4) = resu
Set P = P.Resize(P.Rows.Count + n)
P.Borders.Weight = xlThin 'bordures
P.FormatConditions.Add xlExpression, Formula1:="=$K10=1" 'Mise en forme conditionnelle (MFC)
P.FormatConditions(1).Interior.Color = RGB(217, 217, 217) 'gris
End Sub

Elles s'exécutent automatiquement quand on modifie la cellule D6 ou qu'on active la feuille.

Aucune ligne du tableau n'est supprimée, simplement les lignes qui ne répondent plus au critère sont colorées en gris.

A+

Cliquez pour agrandir...