Amélioration macro

[eduraiss]

Bonjour le forum

Voila le code ci-dessous met les cellules de la colonne B en couleur quand elle sont identique au valeur de la colonne IU2: IU16 mais le traitement n'est pas très rapide. Y aurait-il un moyen plus simple et surtout plus rapide.

Merci
Sub ColorieCelluleJoursFeries()
Application.ScreenUpdating = False



Range("b2:b10000").Select
For Each Cell In Selection


If Cell.Value = Range("iu2") Then
Cell.Interior.ColorIndex = 6
End If

If Cell.Value = Range("iu3") Then
Cell.Interior.ColorIndex = 6
End If

If Cell.Value = Range("iu4") Then
Cell.Interior.ColorIndex = 6
End If

If Cell.Value = Range("iu5") Then
Cell.Interior.ColorIndex = 6 End If

If Cell.Value = Range("iu6") Then
Cell.Interior.ColorIndex = 6
End If

If Cell.Value = Range("iu7") Then
Cell.Interior.ColorIndex = 6
End If

If Cell.Value = Range("iu8") Then
Cell.Interior.ColorIndex = 6
End If

If Cell.Value = Range("iu9") Then
Cell.Interior.ColorIndex = 6
End If

If Cell.Value = Range("iu10") Then
Cell.Interior.ColorIndex = 6
End If

If Cell.Value = Range("iu11") Then
Cell.Interior.ColorIndex = 6
End If

If Cell.Value = Range("iu12") Then
Cell.Interior.ColorIndex = 6
End If

If Cell.Value = Range("iu13") Then
Cell.Interior.ColorIndex = 6
End If

If Cell.Value = Range("iu14") Then
Cell.Interior.ColorIndex = 6
End If

'If Cell.Value = Range("iu15") Then
'Cell.Interior.ColorIndex = 6
'End If

'If Cell.Value = Range("iu116") Then
'Cell.Interior.ColorIndex = 6
'End If



Next
End Sub

 

[jpb388]

Re : Amélioration macro

Bonjour à tous
Teste et dis moi

Sub ColorieCelluleJoursFeries()
Dim Cell As Range, j&
Application.ScreenUpdating = False
For Each Cell In Range("b2:b10000")
  For j = 2 To 14
    If Cell.Value = Range("iu" & j) Then Cell.Interior.ColorIndex = 6
  Next j

Next Cell
End Sub

a+
jp

 

[Dranreb]

Re : Amélioration macro

Bonjour.

Il y a ça qui aurait quelques chances de marcher, et d'être alors beaucoup plus rapide :

Sub ColorieCelluleJoursFeries()
Application.ScreenUpdating = False
CellsColCondR1C1(Cells(2, "B"), "NOT(ISNA(MATCH(RC2,R2C255:R14C255,0)))").Interior.ColorIndex = 6
End Sub

Function CellsColCondR1C1(ByVal CelDéb As Range, ByVal CondR1C1 As String) As Range
Set CellsColCondR1C1 = Intersect(LignesOùCondR1C1(CelDéb, CondR1C1), CelDéb.EntireColumn)
End Function
Function LignesOùCondR1C1(ByVal LigneDéb As Range, ByVal CondR1C1 As String) As Range
Dim Lignes As Range, ColTrv As Range
With LigneDéb.Worksheet.UsedRange
   Set Lignes = LigneDéb.EntireRow.Resize(.Rows.Count + .Row - LigneDéb.Row)
   Set ColTrv = Intersect(.Columns(.Columns.Count + 1), Lignes): End With
ColTrv.FormulaR1C1 = "=1/(" & CondR1C1 & ")"
On Error Resume Next
Set LignesOùCondR1C1 = ColTrv.SpecialCells(xlCellTypeFormulas, 1).EntireRow
ColTrv.Delete xlShiftToLeft
End Function

P.S. Il manquait de toute évidence un Set indispensable, et par simple correction des ByVal. Je n'avais apparemment pas eu souvent l'occasion de l'utiliser ni donc de le tester.

 

[ROGER2327]

Re : Amélioration macro

Bonjour à tous.

Un autre proposition (simple) :​

Sub ColorieCelluleJoursFeries()
Dim Cell As Range, fer(2 To 14), i&, x
    For i = 2 To 14: fer(i) = Cells(i, "IU").Value: Next
    Application.ScreenUpdating = False
    For Each Cell In Range("B2:B10000")
        x = Cell.Value
        For i = 2 To 14
            If x = fer(i) Then Cell.Interior.ColorIndex = 6: Exit For
        Next
    Next
End Sub

Bonne journée.


ℝOGER2327
#7657

Mercredi 4 As 142 (Saint Cravan, boxeur - fête Suprême Quarte)
16 Brumaire An CCXXIII, 5,8149h - chervis
2014-W45-4T13:57:21Z

 

[eduraiss]

Re : Amélioration macro

Bonjour le forum

merci cela marche nickel et cela va un peu plus vite

Cordialement,

 

[ROGER2327]

Re : Amélioration macro

Re...

Bonjour le forum

merci cela marche nickel et cela va un peu plus vite

Cordialement,

Un peu plus vite, oui...

Environ dix fois plus vite, la solution de Dranreb étant légèrement plus rapide que la mienne.​

ℝOGER2327
#7658

Mercredi 4 As 142 (Saint Cravan, boxeur - fête Suprême Quarte)
16 Brumaire An CCXXIII, 5,9010h - chervis
2014-W45-4T14:09:44Z

 

[eduraiss]

Re : Amélioration macro

Re

Oui oui désolé c'est exact j'avais testé celle de jpb338 qui était un peu plus rapide, mais les deux autres le sont nettement plus

Cordialement,