Probleme avec un code

Le 20/01/2015 à 21:00

Bonsoir le forum,

J'ai une erreur dans mon code mais je ne trouve pas laquelle... grrrrrrrrr !!!

Avec ce code, je souhaite que la meilleure valeur de la plage se mette en rouge (font.colorindex 3), ATTENTION, dans cette meme plage il y aura déjà 2 valeurs en rouge (répondant à une autre condition), je ne veux pas prendre en compte ces 2 valeurs déjà rouge...

Voici mon code qui ne fonctionne pas...

'Cas4 la meilleure valeur restante

Set plage = Range("D12,D14,D16,G12,G14:G16,G20,J12:J16,J20,M16,D4,D5,D7,D9,D10,G4,G7,G8,G10,G11,J4,J7:J9,M7,J11")

n = 0

' On boucle pour chercher la meilleure

nbval = Application.WorksheetFunction.Count(plage)

' Pour chaque valeur de la plage, on test si valeur deja en rouge et si pas deja 1 trouvée

For i = 1 To nbval

If n >= 1 Then

v1 = Application.WorksheetFunction.Large(plage, i)

For Each c In plage

If c.Value = v1 Then

n = n + 1

If n >= 1 Then

c.Font.ColorIndex = 3

End If

End If

Next c

End If

Next i

merci pour votre aide

Le 20/01/2015 à 21:10

Bonjour,

Concernant les deux cellules qui sont déjà en rouge ... comment le sont-elles devenues ??? avec une MFC, ou autre ...

Le 20/01/2015 à 21:11

Bonsoir,

Peux-tu :

1) Utiliser les balises CODE la prochaine fois, pour plus de lisibilité

2) Indiquer la ligne qui pose problème (surlignée dans le débogueur)

3) Joindre un fichier, anonymisé si nécessaire

Le 20/01/2015 à 21:18

Désolé pour le code effectivement la prochaine fois j'utiliserai les balises code

soumzoum je n'utilise pas les mfc mais un code vba pour mes 2 cellules

Le 20/01/2015 à 22:06

Voici le code avec une erreur pour info je n'utilise pas la mfc

'Cas4 la meilleure valeur restante
Set plage = Range("D12,D14,D16,G12,G14:G16,G20,J12:J16,J20,M16,D4,D5,D7,D9,D10,G4,G7,G8,G10,G11,J4,J7:J9,M7,J11")

n = 0
' On boucle pour chercher la meilleure
nbval = Application.WorksheetFunction.Count(plage)
' Pour chaque valeur de la plage, on test si valeur deja en rouge et si pas deja 1 trouvée
For i = 1 To nbval
If n >= 1 Then
v1 = Application.WorksheetFunction.Large(plage, i)
For Each c In plage
If c.Value = v1 Then
n = n + 1
If n >= 1 Then
c.Font.ColorIndex = 3
End If
End If
Next c
End If
Next i
Le 20/01/2015 à 22:12

Pas mal, on avance !

Mais il faudrait aussi le fichier, et surtout l'erreur retournée par le débogueur (ainsi que la ligne incriminée)

Le 20/01/2015 à 22:15

Bonsoir,

Et si dans VBA vous redéfinissiez les couleurs, avec un index 10 (par exemple) pour le rouge "Normal" que vous ne voulez pas prendre en compte et un index 20 avec le rouge de la meilleur valeur, à ce moment là vous auriez la possibilité de faire un test si index=10 ne pas prendre en compte, et sur la meilleur valeur mettre rouge index 20...

visuellement les deux rouges restent identiques...

@ bientôt

LouReeD

Le 20/01/2015 à 22:23

voici le fichier en question

la macro défaillante se trouve derrière le bouton d'action Calculer VD (cas 4)

normalement il devrait me mettre en rouge la meilleure valeur parmi les valeurs bleues

4poutre-libre-zone-19012015.xlsm (197.44 Ko)
Le 20/01/2015 à 22:31

Alors selon moi, dans ton fichier, l'instruction conditionnée ne se fait pas car...

n = 0
If n >= 1

Tu affectes la valeur "0" à la variable "n", et tu conditionnes l'instruction pour qu'elle se réalise SSI n est supérieur ou égal à 1

Peut-être regarder de ce côté là?

(Le cas 2 marche car bien que tu affectes 0 à n, la condition est que n soit inférieur à 2)

Le 20/01/2015 à 22:40

j'abeau retourner cela dans tous les sens je n'y arrive pas...

Le 20/01/2015 à 23:06

Bonsoir,

une solution qui met en rouge la cellule contenant la valeur maximum trouvée dans les cellules de plage (A1:A25)qui ne sont pas rouges.

ta question m'a permis de découvrir que s'il y a des fonctions Union et Intersect sur des plages, il n'y a pas de fonction de soustraction sur les plages.

j'ai ajouté cette fonction que j'ai trouvée sur le net.

il y a sûrement moyen de faire plus court. mais je trouvais cette découverte intéressante.

sub maxenrouge()
    Dim enrouge As Range
    Dim plage As Range, re As Range
    Set plage = Range("A1:A25"), 'on définit la plage de recherche

    plage.AutoFilter Field:=1, Criteria1:=RGB(255, 0, 0), Operator:=xlFilterCellColor 'on sélectionne les cases en rouge
    Set re = plage.SpecialCells(xlCellTypeVisible) 'on met la liste des cases en rouge dans re
    If Range("a1").Interior.Color <> 3 Then Set re = SubtractRanges(re, Range("A1")) ' on traite le cas de la cellule A1
    plage.AutoFilter ' on enlève le filtre
    If Not re Is Nothing Then Set plage = SubtractRanges(plage, re) ' on enlève les cases rouges de la plage
    If re.Count < 3 Then 'si il y a moins de 3 cases rouges
        Set re = plage.Find(Application.WorksheetFunction.Max(plage)) ' on cherche le maximum dans la plage adaptée
        If Not re Is Nothing Then
            re.Interior.ColorIndex = 3
        End If
    End If

End Sub

Public Function SubtractRanges(rFirst As Range, rSecond As Range) As Range
'
' Returns a range of cells that are part of rFirst, but not part of rSecond
' (as in set subtraction)
'
' This function handles big input ranges really well!
'
' The reason for having a separate recursive function is
' handling multi-area rFirst range
'
' fonction trouvée sur http://stackoverflow.com/questions/21580795/subtracting-ranges-in-vba-excel
'
    Dim rInter As Range
    Dim rReturn As Range
    Dim rArea As Range

    Set rInter = Intersect(rFirst, rSecond)
    Set mrBuild = Nothing

    If rInter Is Nothing Then    'no overlap
        Set rReturn = rFirst
    ElseIf rInter.Address = rFirst.Address Then    'total overlap
        Set rReturn = Nothing
    Else    'partial overlap
        For Each rArea In rFirst.Areas
            Set mrBuild = BuildRange(rArea, rInter)    'recursive
        Next rArea
        Set rReturn = mrBuild
    End If

    Set SubtractRanges = rReturn
End Function

Private Function BuildRange(rArea As Range, rInter As Range, _
                            Optional mrBuild As Range = Nothing) As Range
'
' Recursive function for SubtractRanges()
'
' Subtracts rInter from rArea and adds the result to mrBuild
'
    Dim rLeft As Range, rRight As Range
    Dim rTop As Range, rBottom As Range
    Dim rInterSub As Range
    Dim GoByColumns As Boolean

    Set rInterSub = Intersect(rArea, rInter)
    If rInterSub Is Nothing Then    'no overlap
        If mrBuild Is Nothing Then
            Set mrBuild = rArea
        Else
            Set mrBuild = Union(mrBuild, rArea)
        End If
    ElseIf Not rInterSub.Address = rArea.Address Then    'some overlap
        If Not rArea.Cells.CountLarge = 1 Then    'just in case there is only one cell for some impossible reason

            ' Decide whether to go by columns or by rows
            ' (helps when subtracting whole rows/columns)
            If Not rInterSub.Columns.Count = rArea.Columns.Count And _
               ((Not rInterSub.Cells.CountLarge = 1 And _
                 (rInterSub.Rows.Count > rInterSub.Columns.Count _
                  And rArea.Columns.Count > 1) Or (rInterSub.Rows.Count = 1 _
                                                   And Not rArea.Columns.Count = 1)) Or _
                                                   (rInterSub.Cells.CountLarge = 1 _
                                                    And rArea.Columns.Count > rArea.Rows.Count)) Then
                GoByColumns = True
            Else
                GoByColumns = False
            End If

            If Not GoByColumns Then
                Set rTop = rArea.Resize(rArea.Rows.Count \ 2)    'split the range top to bottom
                Set rBottom = rArea.Resize(rArea.Rows.Count - rTop.Rows.Count).Offset(rTop.Rows.Count)
                Set mrBuild = BuildRange(rTop, rInterSub, mrBuild)    'rerun it
                Set mrBuild = BuildRange(rBottom, rInterSub, mrBuild)
            Else
                Set rLeft = rArea.Resize(, rArea.Columns.Count \ 2)    'split the range left to right
                Set rRight = rArea.Resize(, rArea.Columns.Count - rLeft.Columns.Count).Offset(, rLeft.Columns.Count)
                Set mrBuild = BuildRange(rLeft, rInterSub, mrBuild)    'rerun it
                Set mrBuild = BuildRange(rRight, rInterSub, mrBuild)
            End If
        End If
    End If

    Set BuildRange = mrBuild
End Function
Le 20/01/2015 à 23:31

bonsoir,

une version simplifiée du code

Sub maxenrouge()

    Set plage = Range("A1:A25")
    m = 0
    For Each c In plage
        If c.Interior.ColorIndex = 3 Then ctrr = ctrr + 1 Else If c > m Then Set m = c
    Next
    If ctrr < 3 Then m.Interior.ColorIndex = 3

End Sub
Le 21/01/2015 à 06:29

Bonjour,

@ h2so4

Merci pour l'info concernant SubtractRanges() ... je ne connaissais pas ... et c'est effectivement bon à savoir ...

Rechercher des sujets similaires à "probleme code"