Effacer les données d'une colonne en fonction de conditions de remplissage

Le 06/12/2019 à 10:26

Bonjour à tous!

Je cherche à utiliser un tableau Excel pour permettre de distribuer des dossiers en fonction de la langue du gestionnaire et dune "tournante".

Dans le fichier en annexe, il faudrait:

  • une mise en forme automatique pour la ligne du gestionnaire suivant. Par exemple, colorer en vert la ligne du gestionnaire de langue FR suivant le dernier encodage X en colonne D et FR en colonne C. De la même manière, on pourrait colorer un bleu le gestionnaire NL suivant en bleu.
  • Quand toute les cellules de la colonne C qui mentionnent FR ont un "X" en colonne D, ces "X" peuvent être effacer pour pouvoir recommencer le tableau des gestionnaires FR à zéro. (Idem pour les gestionnaires NL).

Je suis vraiment en panne pour ces fonctions avec conditions multiples !! Quelqu'un peut-il m'aider???

Merci d'avance!!

8essai.xlsm (14.17 Ko)
Le 06/12/2019 à 10:48

Bonjour,

Pas sûr d'avoir bien saisi la demande ...

mfc evelyne09

ric

Le 06/12/2019 à 14:04

Bonjour Ric!!

Oui effectivement c'est l'idée. J'ai essayé également mais:

- je devrais automatiquement avoir seulement une ligne verte et une ligne bleue vierges (sans "X" dans la colonne D) qui correspondent au prochain gestionnaire NL ou FR de dossier, ce qui n'est pas le cas (voir photo essai doc1). Plusieurs lignes restent en bleu ou vert et quand il y a une alternance de gestionnaires NL ou FR, je perd la ligne "vierge de X" d'une des deux couleur.

- Quand le tableau est rempli complètement, je dois retourner à la situation initiale, à savoir reprendre le 1er gestionnaire FR ou NL présents en haut du tableau.

Je pense donc qu'il faut passer par un VBA mais je ne sais pas coder...

Vous pensez pouvoir m'aider??

5essaidoc1.docx (19.10 Ko)
Le 06/12/2019 à 14:42

Bonjour,

Je n'ai pas bien compris ta demande.

J'ai fait colorer les lignes où il y a X dans la colonne D pour le FR et un Y dans la colonne D pour le NL.

Désolé, mais pour colorer la ligne suivante, je ne sais pas faire ...

ric

Le 06/12/2019 à 16:23

Merci beaucoup pour ton temps Ric!!!

Comme quoi, on peut en apprendre tous les jours!!

Quelqu'un d'autre serait m'aider???

Merci beaucoup d'avance

Le 06/12/2019 à 18:27

Bonjour,

... Je pense donc qu'il faut passer par un VBA mais je ne sais pas coder ...

Si l'on peut passer via VBA ...

Un essai ...

L'on tape n'importe quoi dans la colonne D de façon à dire que c'est complété.

ric

7evelyne09-essai-v2.xlsm (19.22 Ko)
Le 06/12/2019 à 20:18

Salut Evelyne,

Salut Ric,

un début de début de début car le NL ne fonctionne pas encore tout à fait...

Clic en [D] calcule, colore, inscrit le "X" et se cale sur [E]... enfin, c'est l'idéal vers lequel je tends mais le code est encore trop grossier!

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'
Dim iRow%, iRowT%, iRow1%
'
If Not Intersect(Target, Range("D:D")) Is Nothing Then
    If Target.Interior.ColorIndex = 42 Or Target.Interior.ColorIndex = 43 Then
        On Error Resume Next
        iRowT = Target.Row
        iRow = Range("C" & iRowT + IIf(Range("C" & Rows.Count).End(xlUp).Row = iRowT, 1, 0) & ":C" & Range("C" & Rows.Count).End(xlUp).Row + 2).Find(what:=Target.Offset(0, -1), lookat:=xlWhole, LookIn:=xlValues, searchdirection:=xlNext).Row
        'MsgBox iRowT & "  " & iRow
        If iRow = 0 Then
            For x = 2 To iRowT - 1
                If Range("C" & x).Value = Target.Offset(0, -1).Value Then Range("D" & x & ":E" & x).Value = ""
            Next
            iRow = Range("C1:C" & Range("C" & Rows.Count).End(xlUp).Row).Find(what:=Target.Offset(0, -1), lookat:=xlWhole, LookIn:=xlValues, searchdirection:=xlNext).Row
            'MsgBox "2e :  " & iRow
        Else
            iRow1 = Range("C1:C" & Range("C" & Rows.Count).End(xlUp).Row + 1).Find(what:=Target.Offset(0, -1), lookat:=xlWhole, LookIn:=xlValues, searchdirection:=xlPrevious).Row
            If iRow1 <> iRow Then
                Range("A" & iRow1 & ":E" & iRow1).Interior.Color = xlNone
                Range("D" & iRow1 & ":E" & iRow1).Value = ""
            End If
        End If
        Range("A" & iRow & ":E" & iRow).Interior.ColorIndex = Target.Interior.ColorIndex
        Range("A" & iRowT & ":E" & iRowT).Interior.Color = xlNone
        Target = "X"
        Target.Offset(0, 1).Select
        On Error GoTo 0
    End If
    'Target.Interior.ColorIndex = 42
End If
'
End Sub

A tout à l'heure...

A+

7evelyne.xlsm (19.26 Ko)
Le 06/12/2019 à 22:35

Bon, on y est...

Il te suffit de cliquer en [D:D] sur la couleur puisque cette ligne représente ce que tu demandes et la macro fait le reste...

Lors de l'effacement des données lorsque la tournante reprend au début, les derniers dossiers FR et NL de la liste sont maintenus.

Tu devrais préciser combien de dossiers en cours tu veux pouvoir visualiser quel que soit la situation dans la tournante!

Dans cette version, le dernier dossier de la liste sera effacé après le premier appel FR ou NL en début de liste.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'
Dim iRowT%, iRow1%, iRow2%
'
Application.ScreenUpdating = False
'
If Not Intersect(Target, Range("D:D")) Is Nothing Then
    If Target.Interior.ColorIndex = 42 Or Target.Interior.ColorIndex = 43 Then
        On Error Resume Next
        iRowT = Target.Row
        iRow1 = Range("C" & iRowT & ":C" & Range("C" & Rows.Count).End(xlUp).Row).Find(what:=Target.Offset(0, -1), lookat:=xlWhole, LookIn:=xlValues, searchdirection:=xlNext).Row
        If iRow1 = 0 Or iRow1 = iRowT Then
            For x = 2 To iRowT - 1
                If Range("C" & x).Value = Target.Offset(0, -1).Value Then Range("D" & x & ":E" & x).Value = ""
            Next
            iRow1 = Range("C1:C" & Range("C" & Rows.Count).End(xlUp).Row).Find(what:=Target.Offset(0, -1), lookat:=xlWhole, LookIn:=xlValues, searchdirection:=xlNext).Row
        Else
            iRow2 = Range("C1:C" & Range("C" & Rows.Count).End(xlUp).Row).Find(what:=Target.Offset(0, -1), lookat:=xlWhole, LookIn:=xlValues, searchdirection:=xlPrevious).Row
            If iRow2 <> iRow1 Then
                Range("A" & iRow2 & ":E" & iRow2).Interior.Color = xlNone
                Range("D" & iRow2 & ":E" & iRow2).Value = ""
            End If
        End If
        Range("A" & iRow1 & ":E" & iRow1).Interior.ColorIndex = Target.Interior.ColorIndex
        Range("A" & iRowT & ":E" & iRowT).Interior.Color = xlNone
        Target = "X"
        Target.Offset(0, 1).Select
        On Error GoTo 0
    End If
End If
'
Application.ScreenUpdating = True
'
End Sub

A+

8evelyne.xlsm (23.70 Ko)
Le 06/12/2019 à 22:43

Franchement c'est nickel!!!

Je n'ai donc que deux points en suspension:

  • Peut-on garder la colonne des n° de dossiers et en créer une nouvelle (ou l'avoir prévu à la création du fichier, je peux en prévoir une dizaine si nécessaire) une fois la tournante effectuée? (de manière à garder une trace)
  • Que fait-on si l'on clique par "erreur" sur le gestionnaire de l'autre langue?

Sinon, c'est vraiment ce que j'espérais, merci !!!

Le 06/12/2019 à 23:07

Salut Evelyne,

  • une MsgBox de confirmation te suffirait-elle ou vas-tu me dire qu'il peut t'arriver de confirmer par erreur aussi ?
  • en ce qui concerne la sauvegarde des dossiers antérieurs, pas de souci mais ne serait-ce pas bien de placer le dossier en cours en [E] comme maintenant en repoussant chaque fois les plus anciens vers la droite ?

A+

Le 07/12/2019 à 00:52

Salut Evelyne,

Salut Ric,

autre version et une philosophie différente!

La macro ne cherche la prochaine rotation FR ou NL QUE lorsque l'emplacement coloré est complété en [D:D].

Finis les "X" et la possibilité d'erreur est fortement réduite puisque tu as le temps pendant la rédaction du n° de dossier de te rendre compte que tu fais une fausse manoeuvre.

Les colonnes [E...] sont repoussées à droite de 2 cellules pour laisser place au nouveau dossier et à la date d'émission avec encadrement et alternance de couleur accordée plus pâle selon le rôle linguistique.

Qu'en penses-tu ?

Private Sub Worksheet_Change(ByVal Target As Range)
'
Dim iRowT%, iRow%
'
Application.EnableEvents = False
Application.ScreenUpdating = False
'
If Not Intersect(Target, Range("D:D")) Is Nothing Then
    If Target.Interior.ColorIndex = 42 Or Target.Interior.ColorIndex = 43 Then
        On Error Resume Next
        iRowT = Target.Row
        iRow = Range("C" & iRowT & ":C" & Range("C" & Rows.Count).End(xlUp).Row).Find(what:=Target.Offset(0, -1), lookat:=xlWhole, LookIn:=xlValues, searchdirection:=xlNext).Row
        If iRow = 0 Or iRow = iRowT Then _
            iRow = Range("C1:C" & Rows.Count).Find(what:=Target.Offset(0, -1), lookat:=xlWhole, LookIn:=xlValues, searchdirection:=xlNext).Row
        Range("A" & iRow & ":D" & iRow).Interior.ColorIndex = Target.Interior.ColorIndex
        Range("A" & iRowT & ":D" & iRowT).Interior.Color = xlNone
        Range("E" & iRowT & ":F" & iRowT).Insert shift:=xlToRight
        Range("F" & iRowT).Value = Date
        Range("D" & iRowT).Cut Range("E" & iRowT)
        Range("E" & iRowT & ":F" & iRowT).Borders.LineStyle = xlContinuous
        Range("E" & iRowT & ":F" & iRowT).Interior.ColorIndex = IIf(Range("G" & iRowT).Interior.ColorIndex = 2, IIf(Range("C" & iRowT).Value = "FR", 35, 20), 2)
        Columns.AutoFit
        On Error GoTo 0
    End If
End If
'
Application.ScreenUpdating = True
Application.EnableEvents = True
'
End Sub

A tester en situation réelle...

A+

8evelyne.xlsm (24.69 Ko)
Le 09/12/2019 à 08:44

Bonjour Curul is57!

Tu es un ange! C'est exactement ce qu'il me faut ! Ton fichier fonctionne du tonnerre!

Un tout grand merci pour ton investissement et ton aide!

Le 09/12/2019 à 08:56

Encore une petite question :au départ du fichier vierge, la première ligne FR en couleur est la deuxième entrée FR. Est-ce possible de la faire remonter de manière à commencer avec la première personne FR?

Le 09/12/2019 à 13:35

Salut Evelyne,

comme ceci ?

Un double-clic dans [A1:D1] en orange te prépare un fichier vierge.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim iRow%
'
Application.EnableEvents = False
Application.ScreenUpdating = False
'
If Not Intersect(Target, Range("A1:D1")) Is Nothing Then
    Cancel = True
    Cells.Interior.Color = xlNone
    Cells.Borders.LineStyle = xlNone
    Range("E:XFD").Value = ""
    With Range("A1:D1")
        .Interior.ColorIndex = 44
        .Borders.LineStyle = xlContinuous
        .BorderAround Weight:=xlMedium
    End With
    iRow = Range("C:C").Find(what:="FR", lookat:=xlWhole, LookIn:=xlValues, searchdirection:=xlNext).Row
    Range("A" & iRow & ":D" & iRow).Interior.ColorIndex = 43
    iRow = Range("C:C").Find(what:="NL", lookat:=xlWhole, LookIn:=xlValues, searchdirection:=xlNext).Row
    Range("A" & iRow & ":D" & iRow).Interior.ColorIndex = 42
End If
'
Application.ScreenUpdating = True
Application.EnableEvents = True
'
End Sub

Avec plaisir!

A+

4evelyne.xlsm (21.04 Ko)
Le 09/12/2019 à 17:33

Même chose mais j'avais oublié d'effacer les n° de dossier lors du nettoyage.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim iRow%
'
Application.EnableEvents = False
Application.ScreenUpdating = False
'
If Not Intersect(Target, Range("A1:D1")) Is Nothing Then
    Cancel = True
    Cells.Interior.Color = xlNone
    Cells.Borders.LineStyle = xlNone
    Range("D:XFD").Value = ""
    Range("D1").Value = "N°dossier"
    With Range("A1:D1")
        .Interior.ColorIndex = 44
        .Borders.LineStyle = xlContinuous
        .BorderAround Weight:=xlMedium
    End With
    iRow = Range("C:C").Find(what:="NL", lookat:=xlWhole, LookIn:=xlValues, searchdirection:=xlNext).Row
    Range("A" & iRow & ":D" & iRow).Interior.ColorIndex = 42
    iRow = Range("C:C").Find(what:="FR", lookat:=xlWhole, LookIn:=xlValues, searchdirection:=xlNext).Row
    Range("A" & iRow & ":D" & iRow).Interior.ColorIndex = 43
    Range("D" & iRow).Select
End If
'
Application.ScreenUpdating = True
Application.EnableEvents = True
'
End Sub

Que ne ferait-on pour mériter son nouveau statut d'ange...

A+

3evelyne.xlsm (21.89 Ko)
Le 10/12/2019 à 06:14

Bonjour Curulis57!

C'est parfait, parfait!!

J'ai hâte de pouvoir montrer ce nouveau fichier à mes collègues!

Effectivement, tu es vraiment un ange!!! Merci pour tout, mon problème est résolu

A une prochaine fois et bonne continuation

!!

Rechercher des sujets similaires à "effacer donnees colonne fonction conditions remplissage"