XL 2016 VBA - Optimisation d'exécution d'une ligne de code [For Each Cell In Selection > IF... > Next]

[alexanbat]

Bonjour

Je souhaiterais optimiser la vitesse d'execution de ma macro. Je voudrais donc savoir comment je pourrais simplifier ces lignes de codes pour éviter l'effet boucle très chronophage.

        Range("F7:F" & LastRow3, "N7:N" & LastRow3).Select 'Définition de la plage à selectionner

            For Each Cell In Selection

                If Cell.Value = "To be confirmed" Then 'Condition

                    Cell.Interior.Color = RGB(255, 153, 0) 'Orange

                    Cell.Font.Color = RGB(255, 255, 255) ' Blanc

                End If

            Next

Du coup, quelqu'un aurait des suggestions d'optimisation ?

Merci de votre aide
AL

 

[pierrejean]

Bonjour Al

Un tout petit peu plus rapide

Dim zone As Range
          For Each cell In Range("F7:F" & lastrow3, "N7:N" & lastrow3)
                If cell.Value = "To be confirmed" Then 'Condition
                  If zone Is Nothing Then
                     Set zone = cell
                  Else
                   Set zone = Application.Union(zone, cell)
                  End If
                End If
            Next
            zone.Interior.Color = RGB(255, 153, 0) 'Orange
            zone.Font.Color = RGB(255, 255, 255) ' Blanc

 

[alexanbat]

Super merci. Ca marche à merveille.
Avec ce code j'ai gagné en vitesse d'execution.
Al

 

[mapomme]

Bonsoir à tous @alexanbat, @pierrejean

Une autre méthode. Voir module1.

edit: bonsoir @zebanx

 

[Dranreb]

Bonsoir.
Encore un autre système :

Sub Test()
With ColLignesOùRelat(Cells(7, "F"), "F", "=", "To be confirmed")
   .Interior.Color = &H80FF&: .Font.Color = &HFFFFFF: End With
With ColLignesOùRelat(Cells(7, "N"), "N", "=", "To be confirmed")
   .Interior.Color = &H80FF&: .Font.Color = &HFFFFFF: End With
End Sub

Function ColLignesOùRelat(ByVal CelDéb As Range, ByVal ColQuoi, ByVal OPé As String, ByVal Valeur) As Range
Rem. ——— Cellules partant de CelDéb dans sa colonne où la colonne ColQuoi est en relation Opé avec Valeur.
   On Error Resume Next
   Set ColLignesOùRelat = Intersect(LignesOùRelat(CelDéb, ColQuoi, OPé, Valeur), CelDéb.EntireColumn)
   End Function
Function LignesOùRelat(ByVal LigneDéb As Range, ByVal ColQuoi, ByVal OPé As String, ByVal Valeur) As Range
Rem. ——— Lignes entières partant de LigneDéb où la colonne ColQuoi est en relation Opé avec une Valeur.
   If Not IsNumeric(ColQuoi) Then ColQuoi = LigneDéb.Worksheet.Columns(ColQuoi).Column
   If VarType(Valeur) = vbString Then Valeur = """" & Replace(Valeur, _
      """", """""") & """" Else Valeur = Trim$(Str$(Valeur))
   On Error Resume Next
   Set LignesOùRelat = LignesOùCondR1C1(LigneDéb, CondR1C1:="RC" & ColQuoi & OPé & Valeur)
   End Function
Function ColLignesOùCondR1C1(ByVal CelDéb As Range, ByVal CondR1C1 As String) As Range
Rem. ——— Cellules partant de CélDéb dans sa colonne dont les lignes vérifient une condition R1C1 CondR1C1.
   On Error Resume Next
   Set ColLignesOùCondR1C1 = 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
Rem. ——— Lignes entières partant de LigneDéb vérifiant une condition R1C1 CondR1C1.
   Dim Rng As Range
   Set Rng = PlageÀPartirDe(LigneDéb.EntireRow): If Rng Is Nothing Then Exit Function
   Set Rng = Rng.Columns(Rng.Columns.Count + 1)
   Application.ScreenUpdating = False
   On Error Resume Next
   Rng.FormulaR1C1 = "=1/(" & CondR1C1 & ")"
   Set LignesOùCondR1C1 = Rng.SpecialCells(xlCellTypeFormulas, 1).EntireRow
   Rng.Delete xlShiftToLeft
   End Function
Function PlageÀPartirDe(ByVal CelDéb As Range) As Range
Rem. ——— Plage utilisée à partir de CelDéb.
   Dim NbrLig As Long, NBrCol As Long
   With CelDéb.Worksheet.UsedRange:
      NbrLig = .Row + .Rows.Count - CelDéb.Row
      NBrCol = .Column + .Columns.Count - CelDéb.Column
      If NbrLig <= 0 Or NBrCol <= 0 Then Exit Function
      End With
   Set PlageÀPartirDe = CelDéb.Resize(NbrLig, NBrCol)
   End Function

 

[zebanx]

Bonjour Alexanbat, PierreJean , MaPomme, Dranreb, le forum

Merci pour toutes ces propositions qui traitent 10000 lignes en un temps très rapide avec des propositions rédactionnelles une nouvelle fois des plus intéressantes.
Toujours très agréable à lire et à utiliser.

Bonne journée à tous