Optimisation de code, ça rame !

Résolu
Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   -  
Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   -
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.
    NHenry Messages postés 15235 Date d'inscription   Statut Modérateur Dernière intervention   387
     
    Regardes en utilisant Application.ScreenUpdate (ou un truc du genre, je n'ai pas l'environnement)
    0
    1. pijaku Messages postés 13513 Date d'inscription   Statut Modérateur Dernière intervention   2 773
       
      Salut NHenry,

      En VBA : 
      Application.ScreenUpdating = False


      Tu n'étais vraiment pas très loin.
      A++
      0
    2. Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   65
       
      Ca ne change absolument rien.

      Voici mon fichier, je vous laisse constater la lenteur...

      https://www.cjoint.com/c/EHunMdhI3Of

      Cordialement.
      0
  2. Patrice33740 Messages postés 8400 Date d'inscription   Statut Membre Dernière intervention   1 784
     
    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 Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   65
       
      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
  3. michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
     
    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 Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   65
       
      Désolé mais si possible, je préfère vraiment utiliser un code VBA.
      0
  4. Patrice33740 Messages postés 8400 Date d'inscription   Statut Membre Dernière intervention   1 784
     
    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

  5. Vous n’avez pas trouvé la réponse que vous recherchez ?

    Posez votre question
  6. Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   65
     
    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 Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   65
       
      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 Messages postés 8400 Date d'inscription   Statut Membre Dernière intervention   1 784
       
      Il n'y a pas d'évènnement sur la modification de format d'une cellule !
      0
    3. Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   65
       
      Il faut juste le créer.
      0
      1. Patrice33740 Messages postés 8400 Date d'inscription   Statut Membre Dernière intervention   1 784 > Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention  
         
        Si 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
  7. Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   65
     
    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 Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
       
      et bien, reste là dessus
      0
  8. eriiic Messages postés 24581 Date d'inscription   Statut Contributeur Dernière intervention   7 281
     
    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 Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   65
       
      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 Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   65
       
      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 Messages postés 24581 Date d'inscription   Statut Contributeur Dernière intervention   7 281
       
      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 Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   65
       
      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 Messages postés 24581 Date d'inscription   Statut Contributeur Dernière intervention   7 281
       
      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

Discussions similaires

C'est quoi un BILLING ZIP CODE
bikanane -
fabul -

1 réponse