Améliorer une macro avec une boucle
Je cherche une âme charitable qui pourrait si possible me simplifier le code ci-après. Je suis pas vraiment à l'aise avec les boucles. Le but recherché c'est que si les cellules A14, A15, etc sont > 0, en alternance il applique le formatage fond gris et bordure pour la plage A14:I14, pour la plage A15:I15 bordure, etc. Les lignes a traité vont de A14 à A32.
D'avance merci et bonne vacances.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A14")) Is Nothing Then
If Range("A14").Value > 0 Then
With Range("A14:I14")
.Interior.Color = RGB(217, 217, 217) ' Fond gris
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(0, 0, 0) ' Bordure noire
End With
End With
Else
With Range("A14:I14")
.Interior.ColorIndex = xlNone
.Borders.LineStyle = xlNone
End With
End If
End If
If Not Intersect(Target, Range("A15")) Is Nothing Then
If Range("A15").Value > 0 Then
With Range("A15:I15")
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(0, 0, 0) ' Bordure noire
End With
End With
Else
With Range("A15:I15")
.Borders.LineStyle = xlNone
End With
End If
End If
If Not Intersect(Target, Range("A16")) Is Nothing Then
If Range("A16").Value > 0 Then
With Range("A16:I16")
.Interior.Color = RGB(217, 217, 217) ' Fond gris
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(0, 0, 0) ' Bordure noire
End With
End With
Else
With Range("A16:I16")
.Interior.ColorIndex = xlNone
.Borders.LineStyle = xlNone
End With
End If
End If
If Not Intersect(Target, Range("A17")) Is Nothing Then
If Range("A17").Value > 0 Then
With Range("A17:I17")
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(0, 0, 0) ' Bordure noire
End With
End With
Else
With Range("A17:I17")
.Borders.LineStyle = xlNone
End With
End If
End If
If Not Intersect(Target, Range("A18")) Is Nothing Then
If Range("A18").Value > 0 Then
With Range("A18:I18")
.Interior.Color = RGB(217, 217, 217) ' Fond gris
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(0, 0, 0) ' Bordure noire
End With
End With
Else
With Range("A18:I18")
.Interior.ColorIndex = xlNone
.Borders.LineStyle = xlNone
End With
End If
End If
If Not Intersect(Target, Range("A19")) Is Nothing Then
If Range("A19").Value > 0 Then
With Range("A19:I19")
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(0, 0, 0) ' Bordure noire
End With
End With
Else
With Range("A19:I19")
.Borders.LineStyle = xlNone
End With
End If
End If
If Not Intersect(Target, Range("A20")) Is Nothing Then
If Range("A20").Value > 0 Then
With Range("A20:I20")
.Interior.Color = RGB(217, 217, 217) ' Fond gris
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(0, 0, 0) ' Bordure noire
End With
End With
Else
With Range("A20:I20")
.Interior.ColorIndex = xlNone
.Borders.LineStyle = xlNone
End With
End If
End If
If Not Intersect(Target, Range("A21")) Is Nothing Then
If Range("A21").Value > 0 Then
With Range("A21:I21")
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(0, 0, 0) ' Bordure noire
End With
End With
Else
With Range("A21:I21")
.Borders.LineStyle = xlNone
End With
End If
End If
If Not Intersect(Target, Range("A22")) Is Nothing Then
If Range("A22").Value > 0 Then
With Range("A22:I22")
.Interior.Color = RGB(217, 217, 217) ' Fond gris
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(0, 0, 0) ' Bordure noire
End With
End With
Else
With Range("A22:I22")
.Interior.ColorIndex = xlNone
.Borders.LineStyle = xlNone
End With
End If
End If
If Not Intersect(Target, Range("A23")) Is Nothing Then
If Range("A23").Value > 0 Then
With Range("A23:I23")
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(0, 0, 0) ' Bordure noire
End With
End With
Else
With Range("A23:I23")
.Borders.LineStyle = xlNone
End With
End If
End If
If Not Intersect(Target, Range("A24")) Is Nothing Then
If Range("A24").Value > 0 Then
With Range("A24:I24")
.Interior.Color = RGB(217, 217, 217) ' Fond gris
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(0, 0, 0) ' Bordure noire
End With
End With
Else
With Range("A24:I24")
.Interior.ColorIndex = xlNone
.Borders.LineStyle = xlNone
End With
End If
End If
If Not Intersect(Target, Range("A25")) Is Nothing Then
If Range("A25").Value > 0 Then
With Range("A25:I25")
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(0, 0, 0) ' Bordure noire
End With
End With
Else
With Range("A25:I25")
.Borders.LineStyle = xlNone
End With
End If
End If
If Not Intersect(Target, Range("A26")) Is Nothing Then
If Range("A26").Value > 0 Then
With Range("A26:I26")
.Interior.Color = RGB(217, 217, 217) ' Fond gris
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(0, 0, 0) ' Bordure noire
End With
End With
Else
With Range("A26:I26")
.Interior.ColorIndex = xlNone
.Borders.LineStyle = xlNone
End With
End If
End If
If Not Intersect(Target, Range("A27")) Is Nothing Then
If Range("A271").Value > 0 Then
With Range("A27:I27")
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(0, 0, 0) ' Bordure noire
End With
End With
Else
With Range("A27:I27")
.Borders.LineStyle = xlNone
End With
End If
End If
If Not Intersect(Target, Range("A28")) Is Nothing Then
If Range("A28").Value > 0 Then
With Range("A28:I28")
.Interior.Color = RGB(217, 217, 217) ' Fond gris
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(0, 0, 0) ' Bordure noire
End With
End With
Else
With Range("A28:I28")
.Interior.ColorIndex = xlNone
.Borders.LineStyle = xlNone
End With
End If
End If
If Not Intersect(Target, Range("A29")) Is Nothing Then
If Range("A29").Value > 0 Then
With Range("A29:I29")
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(0, 0, 0) ' Bordure noire
End With
End With
Else
With Range("A29:I29")
.Borders.LineStyle = xlNone
End With
End If
End If
If Not Intersect(Target, Range("A30")) Is Nothing Then
If Range("A30").Value > 0 Then
With Range("A30:I30")
.Interior.Color = RGB(217, 217, 217) ' Fond gris
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(0, 0, 0) ' Bordure noire
End With
End With
Else
With Range("A30:I30")
.Interior.ColorIndex = xlNone
.Borders.LineStyle = xlNone
End With
End If
End If
If Not Intersect(Target, Range("A31")) Is Nothing Then
If Range("A31").Value > 0 Then
With Range("A31:I31")
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(0, 0, 0) ' Bordure noire
End With
End With
Else
With Range("A31:I31")
.Borders.LineStyle = xlNone
End With
End If
End If
If Not Intersect(Target, Range("A32")) Is Nothing Then
If Range("A32").Value > 0 Then
With Range("A32:I32")
.Interior.Color = RGB(217, 217, 217) ' Fond gris
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(0, 0, 0) ' Bordure noire
End With
End With
Else
With Range("A32:I32")
.Interior.ColorIndex = xlNone
.Borders.LineStyle = xlNone
End With
End If
End If
End SubBonjour,
Dans un module standard :
Sub ModifierLesLignes(ByVal AireATraiter As Range)
Dim I As Integer
For I = 1 To AireATraiter.Count
With AireATraiter(I)
If .Value > 0 Then
With Range(.Offset(0, 0), .Offset(0, 9))
.Interior.Color = RGB(217, 217, 217) ' Fond gris
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(0, 0, 0) ' Bordure noire
End With
End With
Else
With Range(.Offset(0, 0), .Offset(0, 9))
.Interior.ColorIndex = xlNone
.Borders.LineStyle = xlNone
End With
End If
End With
Next I
End SubDans le module de l'onglet :
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("A14:A32")) Is Nothing Then
ModifierLesLignes Range("A14:A32")
End If
End SubBonjour Eric,
Merci de t'être penché sur mon problème, tes bouts de code fonctionne, mais pas comme je le souhaite. En effet, si tu copies mon code dans la Feui1 tu t'apercevras que mon code grise le fond des cellules une ligne sur deux alors que toi c'est toutes les lignes.
Re,
J'ai tout de même testé tes bouts de codes sur le fichier sur lequel je travaille réellement et qui n'a rien à voir avec le fichier où j'ai testé en premier tes bouts de codes.
Et sur ce fichier, il n'y a aucune ligne qui se met en forme. J'ai peur que la formule qui se trouve en A14 et suivantes n'apprécie pas le codage. Un exemple de ce qui se trouve la cellule A14 et suivante :
=SI(NBVAL(SEMAINES)>=LIGNES($11:12);INDEX(FACTURE!$A$13:$A$36;PETITE.VALEUR(SI(SEMAINES>0;LIGNE(SEMAINES)-12);LIGNES($11:12)));"")
J'ai bien que le problème soit plus complexe voir impossible à résoudre.
bonjour,
la colonne A contient des formules et alors le "vrai" changement est ailleurs, donc soit le "worksheet_Change" a besoin d'un autre "target" soit on a besoin d'un autre evenement, mais il fuat montrer votre fichier (anonymisé) ... pour cela.
Ok,
Sub ModifierLesLignes(ByVal AireATraiter As Range)
Dim I As Integer
With Range(AireATraiter, AireATraiter.Offset(0, 8))
.Interior.ColorIndex = xlNone
.Borders.LineStyle = xlNone
End With
For I = 1 To AireATraiter.Count
With AireATraiter(I)
If .Value > 0 Then
If Not WorksheetFunction.IsEven(I) Then
With Range(.Offset(0, 0), .Offset(0, 8))
.Interior.Color = RGB(217, 217, 217) ' Fond gris
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(0, 0, 0) ' Bordure noire
End With
End With
Else
With Range(.Offset(0, 0), .Offset(0, 8))
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(0, 0, 0) ' Bordure noire
End With
End With
End If
End If
End With
Next I
End SubJ'ai testé ton nouveau code mais il ne fonctionne pas sur la plage A14:A32, certainement à cause de la formule se trouvant à l'intérieure. Donc dans le Workssheet_Change j'ai changé la plage en prenant J14:J32. La code code fonctionne parfaitement mais comme dans le module ModifierLesLignes l'Offset est de 0,8 il met en forme la plage J14:R14. Peut-on mettre en forme la plage A14:A32.
Cordialement
Il faut mettre -8,0 pour les offsets.
La prochaine fois, mettez un fichier, cela évitera les allers-retours.
Salut Eric,
Je te fais passer le fichier anonymisé car le code met en forme toutes les lignes. Attention il va essayé d'ouvrir le fichier client qui n'est pas joint.
Encore merci pour le coup de main.
Cordialement
L'événement serait plutôt Worksheet_Change.
Pourquoi Rnga ne correspond pas à A13:A32 ?
Cell correspond à une valeur Alpha, on ne peut la comparer à 0.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub 'éviter la selection de plusieurs cellules
If Not Intersect(Target, Range("A13:A32")) Is Nothing Then
lig = Target.Row 'donne une valeur à la variable en fonction du clic en colonne A
FormulairePRODUIT_BL.Show 'charge et affiche l'USF
End If
Dim rngA As Range
Set rngA = Range("A13:A32")
' Vérifie si la modification concerne les cellules A14 à A32
If Not Intersect(Target, rngA) Is Nothing Then
' Boucle à travers les cellules A14 à A32
With Range(rngA, rngA.Offset(0, 7))
' Réinitialisation de la mise en forme si la valeur est égale à 0
.Interior.ColorIndex = xlNone
.Borders.LineStyle = xlNone
End With
Dim cell As Range
For Each cell In rngA
If cell.Value <> "" Then
If cell.Row Mod 2 = 0 Then
' Ligne paire : Mise en forme en gris avec bordure noire
Range(cell, cell.Offset(0, 7)).Interior.Color = RGB(192, 192, 192) ' Couleur gris
Range(cell, cell.Offset(0, 7)).Borders.LineStyle = xlContinuous ' Bordure noire
Range(cell, cell.Offset(0, 7)).Borders.Color = RGB(0, 0, 0) ' Couleur de bordure noire
Else
' Ligne impaire : Mise en forme en blanc avec bordure noire
Range(cell, cell.Offset(0, 7)).Interior.Color = RGB(255, 255, 255) ' Couleur blanche
Range(cell, cell.Offset(0, 7)).Borders.LineStyle = xlContinuous ' Bordure noire
Range(cell, cell.Offset(0, 7)).Borders.Color = RGB(0, 0, 0) ' Couleur de bordure noire
End If
Else
End If
Next cell
End If
End SubJ'ai testé ton code sur la feuille1 "FACTURE" mais il ne fonctionne pas. Le formulairePRODUIT_BL ne s'affiche pas.
J'ai passé NrgA en A13:A32, cela fonctionne j'avais mis A14 car j'avais déjà mis en forme la première ligne.
Je ne cherchais pas à modifier les codes de la feuille1 mais celui de la feuille2 "BL". Malgré le petit changement ci dessus mon problème reste le même.
Il faut utiliser l'évènement sélection change seulement pour lancer le formulaire.
Désolé, Eric mais je ne comprends le but de ta démarche.
C'est un membre du site qui m'a aidé dans le code de la feuille1. Il fonctionne et je pense que je vais rester avec mes lignes de code à rallonge pour la feuille2.
Encore merci d'avoir passé du temps sur mon problème et désolé d'avoir accaparé ton temps.
Bon courage à tous et à bientôt.
Voilà le code qui me permet de mettre en forme mes cellules.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Dim cell As Range
Dim i As Long
Set rng = Range("A13:I32")
If Not Intersect(Target, Range("J13:J32")) Is Nothing Then
Application.EnableEvents = False ' Désactive les événements pour éviter une boucle infinie
For Each cell In rng.Rows
i = i + 1
If i Mod 2 = 0 Then
If Cells(cell.Row, "J").Value > 0 Then
cell.Interior.Color = RGB(217, 217, 217) ' Fond gris
With cell.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(0, 0, 0) ' Bordure noire
End With
Else
cell.Interior.ColorIndex = xlNone
cell.Borders.LineStyle = xlNone
End If
Else
If Cells(cell.Row, "J").Value > 0 Then
With cell.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(0, 0, 0) ' Bordure noire
End With
Else
cell.Borders.LineStyle = xlNone
End If
End If
Next cell
Application.EnableEvents = True ' Réactive les événements
End If
End SubEncore merci à tous pour l'aide.