Optimisation de code, ça rame !

Résolu
Kuartz -  
Bonjour,

Le code suivant a pour but de colorer en jaune les lignes dont la colonne P sont les mêmes si la colonne Q est colorée en jaune. 

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

Dim DL As Long

DL = ActiveSheet.Cells(Application.Rows.Count, 1).End(xlUp).Row

For i = 1 To DL
For j = 1 To DL

If ActiveSheet.Range("Q" & i).Interior.Color = RGB(255, 255, 0) Then
    If CStr(ActiveSheet.Range("P" & i).Value) = CStr(ActiveSheet.Range("P" & j).Value) Then
        ActiveSheet.Range("P" & j).Interior.Color = RGB(255, 255, 0)
        ActiveSheet.Range("Q" & j).Interior.Color = RGB(255, 255, 0)
    End If
End If

Next j

Next i

End Sub


Seulement voilà, ça rame sévère tout le temps.... Surtout quand la feuille comporte pas mal de lignes....

Une idée pour optimiser tout ça et qu'on puisse utiliser le fichier normalement?

Merci d'avance.

7 réponses

  1.  eriiic Contributeur
    Bonjour,

    Un essai. J'ai supprimé ta ligne vide et la fusion inutile.
    Double-cliquer sur ton n° en Q
    https://www.cjoint.com/c/EHvgv0SoMDb
    eric
    0
    1. Kuartz Auteur
      Bonjour,

      Désolé pour la réponse tardive, j'étais en vacances. Ce code a l'air vraiment génial. Par contre petit soucis, excel me dit parfois : "La méthode Range de l'objet global Autofilter a échoué".

      Merci en tout cas !

      Cordialement.
      0
    2. Kuartz Auteur
      Un autre petit problème. Ouvre le fichier, double clique sur chaque ligne une à une, parfois en double cliquant sur une ligne, l'écran par vers le bas du tableau et rien ne se passe.
      0
    3. eriiic Contributeur
      Bonjour,

      Heuuuu, 3 semaines après tu obliges à tout relire et à tout reprendre à zéro pour savoir ce que tu voulais et ce qui était proposé. Ca ne motive pas...
      excel me dit parfois : "La méthode Range de l'objet global Autofilter a échoué".
      Sans exemple précis et les manip à faire pour reproduire je ne peux rien chercher.
      parfois en double cliquant sur une ligne, l'écran par vers le bas du tableau et rien ne se passe.
      C'est le fonctionnement normal d'excel quand tu double-cliques sur le bord d'une cellule.

      eric
      0
    4. Kuartz Auteur
      Bonjour,

      Je comprend, mais je n'arrive pas à reproduire l'erreur avec un exemple précis. J'ai l'impression que c'est plus ou moins aléatoire.

      Est-il possible de désactiver ce "fonctionnement normal"?

      Désolé d'avoir répondu si tardivement. Je n'avais pas internet. Laissez tomber sinon, je ferai avec.

      Merci beaucoup de votre aide en tout cas.

      Cordialement.
      0
    5. eriiic Contributeur
      Est-il possible de désactiver ce "fonctionnement normal"?
      Plus simple de cliquer au milieu, zoome si tu as du mal, ou bien utilise l'événement clic-droit Worksheet_BeforeRightClick() à la place.
      eric
      0
  2. Kuartz Auteur
    Après recherche, voici mon code qui me convient déjà beaucoup mieux : 

    Option Explicit

Dim x As Integer
Dim Cell As String


Sub Code()

Application.ScreenUpdating = False

Dim DL As Long
Dim i As Long
Dim j As Long

DL = ActiveSheet.Cells(Application.Rows.Count, 3).End(xlUp).Row

For i = 1 To DL
For j = 1 To DL

If ActiveSheet.Range("Q" & i).Interior.Color = RGB(255, 255, 0) Then
    If CStr(ActiveSheet.Range("P" & i).Value) = CStr(ActiveSheet.Range("P" & j).Value) Then
        ActiveSheet.Range("P" & j).Interior.Color = RGB(255, 255, 0)
        ActiveSheet.Range("Q" & j).Interior.Color = RGB(255, 255, 0)
    End If
End If

Next j

Next i

End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
        x = ActiveCell.Interior.ColorIndex
        Cell = ActiveCell.Address
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    On Error Resume Next
    
    If Cell = "" Then
        x = Target.Interior.ColorIndex
        Cell = Target.Address
        Exit Sub
    End If
    
    If Range(Cell).Interior.ColorIndex <> x Then _
        Call Code
    
    x = Target.Interior.ColorIndex
    Cell = Target.Address
End Sub
    0
    1. michel_m Contributeur
      et bien, reste là dessus
      0
  3. Kuartz Auteur
    Sinon, s'il était possible de rajouter un code du genre "Si la couleur d'une cellule a été modifiée alors le code s'exécute".

    Du coup ça ramerait moins le reste du temps.

    J'ai essayé un "If Not Intersect(Target, Range("Q:Q")) Is Nothing Then"

    Mais bon c'est pas vraiment ce que je veux.
    0
    1. Kuartz Auteur
      Je sais qu'on peut mettre un "Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)", mais un changement de couleur n'est pas considéré comme un changement...
      0
    2. Patrice33740
      Il n'y a pas d'évènnement sur la modification de format d'une cellule !
      0
    3. Kuartz Auteur
      Il faut juste le créer.
      0
    4. Patrice33740
      @KuartzSi tu as une solution pour créer un évènement sur changement de format, je suis preneur (et je ne suis pas le seul !)

      As-tu essayé le dernier code que je t'ai proposé (à 16h58) ?
      0
  4. Patrice33740
    Re,

    Essaies ce code dans le module de la feuille : 
    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Static cel As Range
Dim n°L As Long

  If cel Is Nothing Then Set cel = ActiveCell
  If Intersect(cel, Columns("Q:Q")) Is Nothing Then
    Set cel = ActiveCell
    Exit Sub
  End If
  If cel.Interior.Color <> RGB(255, 255, 0) Then
    Columns("P:Q").Interior.Color = RGB(255, 255, 255)
    Set cel = ActiveCell
    Exit Sub
  End If
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  Columns("P:Q").Interior.Color = RGB(255, 255, 255)
  For n°L = 1 To Cells(Application.Rows.Count, 3).End(xlUp).Row
    If Cells(n°L, "P").Value = cel.Offset(0, -1).Value Then
      Cells(n°L, "P").Resize(1, 2).Interior.Color = RGB(255, 255, 0)
    End If
  Next n°L
  Set cel = ActiveCell
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True

End Sub

    0
    2. michel_m Contributeur
      Bonjour,

      en début de macro:
      application.screenupdating=false

      te fera gagner du temps mais pour le reste j'essaierai sans en ^tre sûr,non par VBA, mais par mise en forme conditionnelle
      0
      1. Kuartz Auteur
        Désolé mais si possible, je préfère vraiment utiliser un code VBA.
        0
    3. Patrice33740
      Bonjour,

      Ce code est très redondant !!!

      Il recolore en jaune (Px:Qx) les tous les doublons de la colonne P dont la colonne Q est jaune.

      Que voulais-tu faire exactement ???

      Un fichier exemple serait le bienvenu !
      0
      1. Kuartz Auteur
        Et bien le fichier exemple est joint plus haut. En fait, voilà de façon mathématique ma demande :

        Si je colore une cellule Q de la ligne x, alors on prend la valeur de la colonne P de la ligne x. Si cette valeur est retrouvée plusieurs fois (toujours dans la colonne P du fichier), alors pour toutes ces lignes, les colonnes P et Q devront être colorée en jaune.

        Cordialement.
        0
    4. NHenry Modérateur
      Regardes en utilisant Application.ScreenUpdate (ou un truc du genre, je n'ai pas l'environnement)
      0
      1. pijaku Modérateur
        Salut NHenry,

        En VBA : 
        Application.ScreenUpdating = False


        Tu n'étais vraiment pas très loin.
        A++
        0

    Discussions similaires

    C'est quoi un BILLING ZIP CODE
    bikanane

    1 réponse