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.
A voir également:

7 réponses

Réponse 1 / 7
NHenry Messages postés 15479 Statut Modérateur 366
 
Regardes en utilisant Application.ScreenUpdate (ou un truc du genre, je n'ai pas l'environnement)
0
pijaku Messages postés 13513 Statut Modérateur 2 763
 
Salut NHenry,

En VBA : 
Application.ScreenUpdating = False


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

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

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

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

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

Posez votre question
Réponse 5 / 7
Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   62
 
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
Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   62
 
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
Patrice33740 Messages postés 8930 Statut Membre 1 781
 
Il n'y a pas d'évènnement sur la modification de format d'une cellule !
0
Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   62
 
Il faut juste le créer.
0
Patrice33740 Messages postés 8930 Statut Membre 1 781 > 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
Réponse 6 / 7
Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   62
 
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
michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 318
 
et bien, reste là dessus
0
Réponse 7 / 7
eriiic Messages postés 25847 Statut Contributeur 7 279
 
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
Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   62
 
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
Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   62
 
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
eriiic Messages postés 25847 Statut Contributeur 7 279
 
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
Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   62
 
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
eriiic Messages postés 25847 Statut Contributeur 7 279
 
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