Probleme avec un code
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
Bonjour,
Concernant les deux cellules qui sont déjà en rouge ... comment le sont-elles devenues ??? avec une MFC, ou autre ...
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
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
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
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)
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
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
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)
j'abeau retourner cela dans tous les sens je n'y arrive pas...
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
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
Bonjour,
@ h2so4
Merci pour l'info concernant SubtractRanges() ... je ne connaissais pas ... et c'est effectivement bon à savoir ...