Colorier des lignes en fonction des colonnes

Le 02/11/2017 à 16:16

Bonjour,

je souahite a partir de deux colonnes colorier une lignes qui iras du numero de la prémiére colonne au numero de la déuxieme colonne.

voici un fichier qui détaille ma problématique.

merci pour votre aide

cordialement

8problematique.xlsx (7.91 Ko)
Le 02/11/2017 à 16:41

Salut elfarmoh,

quelque chose comme ça?

Private Sub Worksheet_Change(ByVal Target As Range)
'
Application.EnableEvents = False
'
If Not Intersect(Target, Range("F:G")) Is Nothing Then
    If Target < 1000 Then
        MsgBox "Donnée invalide!", vbCritical, "Echelle"
        Target = ""
        Target.Select
        iOK = 1
    End If
    iRow = Target.Row
    Range(Cells(iRow, 8), Cells(iRow, Columns.Count)).Interior.Color = xlNone
    If Cells(iRow, 6) <> "" And Cells(iRow, 7) <> "" And iOK = 0 Then
        Range(Cells(iRow, -992 + CInt(Cells(iRow, 6))), Cells(iRow, -992 + CInt(Cells(iRow, 7)))).Interior.Color = RGB(91, 155, 213)
    End If
End If
'
Application.EnableEvents = True
'
End Sub

A+

12problematique.xlsm (14.50 Ko)
Le 02/11/2017 à 16:54

Bonjour,

Code à attacher à un bouton :

Sub Test()

    Dim PlgEntete As Range
    Dim PlgVal As Range
    Dim Cel As Range
    Dim CelDeb As Range
    Dim CelFin As Range

    With Worksheets("Feuil1"): Set PlgEntete = .Range(.Cells(1, 1).End(xlToRight), .Cells(1, .Columns.Count).End(xlToLeft)): End With
    With Worksheets("Feuil1"): Set PlgVal = .Range(.Cells(1, 6).End(xlDown), .Cells(.Rows.Count, 6).End(xlUp)): End With

    PlgEntete.Resize(PlgVal.Rows.Count + 1, PlgEntete.Columns.Count).Interior.ColorIndex = 0

    For Each Cel In PlgVal

        Set CelDeb = PlgEntete.Find(Cel.Value, , xlValues, xlWhole)

        If Not CelDeb Is Nothing Then

            Set CelFin = PlgEntete.Find(Cel.Offset(, 1).Value, , xlValues, xlWhole)

            If Not CelFin Is Nothing Then: Range(Cells(Cel.Row, CelDeb.Column), Cells(Cel.Row, CelFin.Column)).Interior.ColorIndex = 3

        End If

    Next Cel

End Sub
Le 02/11/2017 à 16:55

Bonjour Theze,

Merci beaucoup pour ta réponse.

Parcontre je voudrais insérer des lignes sans avoir un message d'erreur qui apparais?

cela est possible ?

Cordialement

Le 02/11/2017 à 17:21

j'ai oublier de préciser que les lignes a prendre en compte en haut debut a la ligne 3

Le 02/11/2017 à 17:25

Ton classeur en retour !

18test-problematique.xlsm (15.77 Ko)
Le 02/11/2017 à 21:32

voilà le vrai résultat souhaitée:

8classeur1.xlsx (7.94 Ko)
Le 02/11/2017 à 21:42

Je te re poste le code avec les modifs, code qui marche très bien sur ton dernier classeur :

Sub Test()

    Dim PlgEntete As Range
    Dim PlgVal As Range
    Dim Cel As Range
    Dim CelDeb As Range
    Dim CelFin As Range

    With Worksheets("Feuil1"): Set PlgEntete = .Range(.Cells(3, 1).End(xlToRight), .Cells(3, .Columns.Count).End(xlToLeft)): End With
    With Worksheets("Feuil1"): Set PlgVal = .Range(.Cells(1, 6).End(xlDown), .Cells(.Rows.Count, 6).End(xlUp)): End With

    PlgEntete.Resize(PlgVal.Rows.Count + 1, PlgEntete.Columns.Count).Interior.ColorIndex = 0

    For Each Cel In PlgVal

        Set CelDeb = PlgEntete.Find(Cel.Value, , xlValues, xlWhole)

        If Not CelDeb Is Nothing Then

            Set CelFin = PlgEntete.Find(Cel.Offset(, 1).Value, , xlValues, xlWhole)

            If Not CelFin Is Nothing Then: Range(Cells(Cel.Row, CelDeb.Column), Cells(Cel.Row, CelFin.Column)).Interior.ColorIndex = 33

        End If

    Next Cel

End Sub
Le 02/11/2017 à 21:54

c'est parfais ça ça marche niquel.

Merci mais est ce que tu pense que c'est possible de faire cela en direct sans avoir a appuyer sur un bouton ?

Le 02/11/2017 à 22:26

Certes, cela fonctionne depuis belle lurette mais, pour s'en rendre compte, il faudrait au minimum avoir la politesse et l'élégance de répondre à ceux qui se cassent stupidement la tête pour résoudre les demandes exposées!

11problematique.xlsm (14.62 Ko)
Le 02/11/2017 à 22:47

Curulis57,

Je répond a tout les messages qui sont poster sur ma demande et je rémercie les intervénants a chaque fois.

Je voudrais avoir des explications au sujet du fichier que t'as envoyer?

cordialement.

Le 03/11/2017 à 10:26

Il y a un deuxième point que j'ai oublier de mentioner.

Les chiffres en haut ne se suivent pas forcement il peut y avoir des ecarts mais ils sont toujours ranger dan sl'ordre croisant.

Voici un exemple.

Cordialemet

8problematique.xlsx (7.95 Ko)
Le 03/11/2017 à 15:09

Bonjour,

Oui, et c'est quoi le problème ? Le dernier code que je t'ai donné fonctionne que les nombres se suivent ou pas ou alors, il y a quelque chose qui m'échappe !

Le 03/11/2017 à 15:31

Enfaite ton code fonctionne trés bien lorsqu'on veut utiliser un bouton a chaque nouvel saisi.

Le code de curulis fonctionne automatiquement mais juste avec les nombres qui se suivent.

Je voudrais donc savoir s'il étais possible d'automatisé ta macro afin de pas avoir a appuyer sur le bouton a chaque fois qu'on rajoute une nouvelle ligne.

Sinon a part ça ton code répond trés bien au besoin final.

Cordialement

Le 03/11/2017 à 15:53

Salut l'équipe,

Private Sub Worksheet_Change(ByVal Target As Range)
'
Application.EnableEvents = False
'
If Not Intersect(Target, Range("F:G")) Is Nothing Then
    iRow = Target.Row
    If Target < 1000 Or Cells(iRow, 6) > Cells(iRow, 7) Then
        MsgBox "Donnée invalide!", vbCritical, "Echelle"
        Target = ""
        Target.Select
        iOK = 1
    End If
    Range(Cells(iRow, 8), Cells(iRow, Columns.Count)).Interior.Color = xlNone
    If Cells(iRow, 6) <> "" And Cells(iRow, 7) <> "" And iOK = 0 Then
        Range(Cells(iRow, -992 + CInt(Cells(iRow, 6))), Cells(iRow, -992 + CInt(Cells(iRow, 7)))).Interior.Color = RGB(91, 155, 213)
    End If
End If
'
Application.EnableEvents = True
'
End Sub

A+

Le 03/11/2017 à 16:11

Donc, dans ce cas, deux solutions, soit sur la procédure événementielle "SelectionChange()" et tu appelles ma procédure de cette façon :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Test

End Sub

Quelle que soit la cellule sélectionnée la procédure sera exécutée.

Si tu veux que ça ne soit exécuté que quand tu sélectionnes une cellule de la plage, tu peux la définir avec cette petite fonction que je me suis créée pour définir une plage quand elle se trouve en milieu de feuille (attention, ça prend la cellule la plus en haut à gauche et la cellule la plus en bas à droite) :

Function DefPlageMilieuFeuille(Fe As Worksheet) As Range

    On Error GoTo Fin

    With Fe

        Set DefPlage = .Range(.Cells(.Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), -4123, , 2, 2).Row, _
                       .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), -4123, , 2, 1).Column), _
                       .Cells(.Cells.Find("*", .Cells(1, 1), -4123, , _
                       1, 2).Row, .Cells.Find("*", .Cells(1, 1), -4123, , _
                       2, 2).Column))

    End With

    Exit Function

Fin:

    Set DefPlage = Nothing

End Function

Donc, voici le code complet à mettre dans le module de la feuille :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Dim Plage As Range

    Set Plage = DefPlageMilieuFeuille(ActiveSheet)

    If Not Intersect(Target, Plage) Is Nothing Then Test

End Sub

Sub Test()

    Dim PlgEntete As Range
    Dim PlgVal As Range
    Dim Cel As Range
    Dim CelDeb As Range
    Dim CelFin As Range

    With ActiveSheet: Set PlgEntete = .Range(.Cells(3, 1).End(xlToRight), .Cells(3, .Columns.Count).End(xlToLeft)): End With
    With ActiveSheet: Set PlgVal = .Range(.Cells(1, 6).End(xlDown), .Cells(.Rows.Count, 6).End(xlUp)): End With

    PlgEntete.Resize(PlgVal.Rows.Count + 1, PlgEntete.Columns.Count).Interior.ColorIndex = 0

    For Each Cel In PlgVal

        Set CelDeb = PlgEntete.Find(Cel.Value, , xlValues, xlWhole)

        If Not CelDeb Is Nothing Then

            Set CelFin = PlgEntete.Find(Cel.Offset(, 1).Value, , xlValues, xlWhole)

            If Not CelFin Is Nothing Then: Range(Cells(Cel.Row, CelDeb.Column), Cells(Cel.Row, CelFin.Column)).Interior.ColorIndex = 33

        End If

    Next Cel

End Sub

Function DefPlageMilieuFeuille(Fe As Worksheet) As Range

    On Error GoTo Fin

    With Fe

        Set DefPlage = .Range(.Cells(.Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), -4123, , 2, 2).Row, _
                       .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), -4123, , 2, 1).Column), _
                       .Cells(.Cells.Find("*", .Cells(1, 1), -4123, , _
                       1, 2).Row, .Cells.Find("*", .Cells(1, 1), -4123, , _
                       2, 2).Column))

    End With

    Exit Function

Fin:

    Set DefPlage = Nothing

End Function

Soit sur la procédure événementielle "Change()" et dans ce cas, il faudrait savoir quelles sont les valeurs modifiées ?

Petite correction dans ma fonction, supprimer et remplacer par :

Function DefPlageMilieuFeuille(Fe As Worksheet) As Range

    On Error GoTo Fin

    With Fe

        Set DefPlageMilieuFeuille = .Range(.Cells(.Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), -4123, , 2, 2).Row, _
                                    .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), -4123, , 2, 1).Column), _
                                    .Cells(.Cells.Find("*", .Cells(1, 1), -4123, , _
                                    1, 2).Row, .Cells.Find("*", .Cells(1, 1), -4123, , _
                                    2, 2).Column))

    End With

    Exit Function

Fin:

    Set DefPlageMilieuFeuille = Nothing

End Function
Le 05/11/2017 à 13:56

Bonjour voila c’est exactement ce que je rechercher comme resultat.

Je vous remerci tout les deuce pour vos responses vous Aller me faire gangner beaucoup de temp.

Cordialement

Rechercher des sujets similaires à "colorier lignes fonction colonnes"