XL 2016 Exécution lente des macros

halecs93

halecs93

XLDnaute Impliqué
Bonjour à tout le monde,

J'ai deux évènements correspondant à la l'onglet "planning" qui, je crois ralentissent les calculs.

Il s'agit de :

Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
et
Worksheet_Change(ByVal Target As Range)

Existerait il un moyen d'accélérer le traitement du classeur ?

Merci beaucoup.
 

Pièces jointes

  • PLANNING - exceldownoads - accelerer macro.xlsm
    453.6 KB · Affichages: 18
Trier par date Trier par votes
TooFatBoy

TooFatBoy

XLDnaute Barbatruc
halecs93 à dit:
Du coup, je me classe du côté des cons.
Cliquez pour agrandir...
😲

halecs93 à dit:
Non, je n'ai rien compris.
Cliquez pour agrandir...
En #54 j'expliquais comment voir si une cellule est coloriée par une MFC.
Si la couleur de fond indiquée dans "Format de cellule" puis "Remplissage" n'est pas la même que la couleur que tu vois à l'écran, cela veut dire que c'est une MFC qui modifie la couleur de la cellule.
 
Vote positif 0 Vote négatif
halecs93

halecs93

XLDnaute Impliqué
TooFatBoy à dit:
Non, je ne peux pas faire ça, car je ne comprends pas ce que fait la macro Change de ta feuille "Planning". :(
Cliquez pour agrandir...
Là, je suis désolé....la seule chose, c'est qu'elle ne se pré-occupe pas de savoir si les cellules sont vides ou pas.

Ca gère juste le fait que des créneaux horaires se chevauchent pour une même personne, et ça applique la même couleur en fonction du nom de la personne
 
Vote positif 0 Vote négatif
TooFatBoy

TooFatBoy

XLDnaute Barbatruc
Pour moi, c'est là que se trouve le problème, mais je ne saurais t'en dire plus :( :
VB: 
    ' Nouveau code pour la mise en forme conditionnelle basée sur la liste déroulante
    Set cellsBtoN = plan.Range("B:N")
    If Not Intersect(Target, cellsBtoN) Is Nothing Then
        For Each cell In Intersect(Target, cellsBtoN)
            Set cellQ = plan.Columns("S:S").Find(What:=cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
            If Not cellQ Is Nothing Then
                cell.Interior.Color = cellQ.Interior.Color
            End If
        Next cell
    End If
 
Vote positif 0 Vote négatif
halecs93

halecs93

XLDnaute Impliqué
TooFatBoy à dit:
Pour moi, c'est là que se trouve le problème, mais je ne saurais t'en dire plus :( :
VB: 
    ' Nouveau code pour la mise en forme conditionnelle basée sur la liste déroulante
    Set cellsBtoN = plan.Range("B:N")
    If Not Intersect(Target, cellsBtoN) Is Nothing Then
        For Each cell In Intersect(Target, cellsBtoN)
            Set cellQ = plan.Columns("S:S").Find(What:=cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
            If Not cellQ Is Nothing Then
                cell.Interior.Color = cellQ.Interior.Color
            End If
        Next cell
    End If
Cliquez pour agrandir...
oui, c'est la partie qui permet de coloriser la cellule "nom". Vais essayer de regarder ça
 
Vote positif 0 Vote négatif
TooFatBoy

TooFatBoy

XLDnaute Barbatruc
Eh oui : la cellule trouvée est la cellule S42, qui est la première cellule vide, donc ta cellule prend la même couleur, c'est-à-dire gris.

Mais, à mon avis, il n'y a pas à chercher à colorier cette cellule par macro.

Seules les cellules contenant des listes déroulantes devraient être coloriées par MFC, et seulement si la cellule n'est pas vide !
Toutes les autres cellules du tableau ne devraient pas être affectées par la macro.
 
Vote positif 0 Vote négatif
TooFatBoy

TooFatBoy

XLDnaute Barbatruc
La macro corrigée comme je crois qu'elle devrait agir :
VB: 
Private Sub Worksheet_Change(ByVal Target As Range)
'
Dim plan As Worksheet, auxil As Worksheet, coll As New Collection
Dim xrgValid As Range, n&, x, I&, k&
Dim cellsBtoN As Range, cell As Range, cellQ As Range
Dim Nbcb As Long, Nbcv As Long
Dim aaa

    Application.ScreenUpdating = False

    Set plan = Worksheets("PLANNING")

    ' Création d'une feuille nommée "Auxilxxx" (si elle existe déjà on commence par la supprimer)
    On Error Resume Next
    Application.DisplayAlerts = False
    Application.Worksheets("Auxilxxx").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    With Application.Worksheets.Add: .Name = "Auxilxxx": End With
    Set auxil = Worksheets("Auxilxxx")

    ' On met le texte, des colonnes B à N, en noir et non gras
    plan.Range("B3:N" & Rows.count).Font.Color = vbBlack
    plan.Range("B3:N" & Rows.count).Font.Bold = False

    ' Affectation à la variable xrgValid de toutes les cellules du tableau contenant une liste déroulante
    Set xrgValid = plan.[B5].SpecialCells(xlCellTypeSameValidation)

    '---------- Calcule le nombre de cellules non vides de la plage ------
    Nbcv = xrgValid.count                                   ' Nombre de cellules de la plage (la plage étant l'ensemble des cellules du tableau ayant une liste déroulante)
    Nbcb = xrgValid.SpecialCells(xlCellTypeBlanks).count    ' Nombre de cellules vides de la plage (la plage étant l'ensemble des cellules du tableau ayant une liste déroulante)
    '-----------------------------------------------------------------

    ReDim t(1 To Nbcv - Nbcb, 1 To 6)
    auxil.Cells.Delete
    For Each x In xrgValid.Cells
        If x.Value <> "" Then
            If x.Offset(-1) <> "" Then
                n = n + 1
                t(n, 1) = x.Column
                t(n, 2) = x.Value
                t(n, 3) = TimeValue(Split(x.Offset(-1), "-")(0))
                t(n, 4) = TimeValue(Split(x.Offset(-1), "-")(1))
                t(n, 5) = x.Row
                t(n, 6) = Format(t(n, 1), "0000") & String(50 - Len(t(n, 2)), " ") & t(n, 2) & Format(t(n, 3), "hhmm") & Format(t(n, 4), "hhmm")
            End If
        End If
    Next x
    auxil.[A1].Resize(n, 6) = t
    auxil.[A1].Resize(n, 6).Sort key1:=auxil.[F1], order1:=xlAscending, MatchCase:=False, Header:=xlNo
    t = auxil.[A1].Resize(n, 5).Value

    ' On supprime la feuille nommée "Auxilxxx"
    On Error Resume Next
    Application.DisplayAlerts = False
    auxil.Delete
    Application.DisplayAlerts = True
    On Error GoTo 0

    For I = 2 To UBound(t)
        If t(I, 1) = t(I - 1, 1) And t(I, 2) = t(I - 1, 2) And t(I, 3) < t(I - 1, 4) Then
            plan.Cells(t(I, 5), t(I, 1)).Font.Color = vbRed
            plan.Cells(t(I, 5), t(I, 1)).Font.Bold = True
            plan.Cells(t(I - 1, 5), t(I - 1, 1)).Font.Color = vbRed
            plan.Cells(t(I - 1, 5), t(I - 1, 1)).Font.Bold = True
            On Error Resume Next
            coll.Add "", t(I, 5) & "/" & t(I, 1)
            coll.Add "", t(I - 1, 5) & "/" & t(I - 1, 1)
            On Error GoTo 0
        End If
    Next I

    ' Nouveau code pour la mise en forme conditionnelle basée sur la liste déroulante
'    Set cellsBtoN = plan.Range("B:N")
    Set cellsBtoN = xrgValid
    If Not Intersect(Target, cellsBtoN) Is Nothing Then
        For Each cell In Intersect(Target, cellsBtoN)
            If cell.Value <> "" Then
                Set cellQ = plan.Columns("S:S").Find(What:=cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
                If Not cellQ Is Nothing Then cell.Interior.Color = cellQ.Interior.Color
            End If
        Next cell
    End If

End Sub
 
Vote positif 0 Vote négatif
halecs93

halecs93

XLDnaute Impliqué
TooFatBoy à dit:
La macro corrigée comme je crois qu'elle devrait agir :
VB: 
Private Sub Worksheet_Change(ByVal Target As Range)
'
Dim plan As Worksheet, auxil As Worksheet, coll As New Collection
Dim xrgValid As Range, n&, x, I&, k&
Dim cellsBtoN As Range, cell As Range, cellQ As Range
Dim Nbcb As Long, Nbcv As Long
Dim aaa

    Application.ScreenUpdating = False

    Set plan = Worksheets("PLANNING")

    ' Création d'une feuille nommée "Auxilxxx" (si elle existe déjà on commence par la supprimer)
    On Error Resume Next
    Application.DisplayAlerts = False
    Application.Worksheets("Auxilxxx").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    With Application.Worksheets.Add: .Name = "Auxilxxx": End With
    Set auxil = Worksheets("Auxilxxx")

    ' On met le texte, des colonnes B à N, en noir et non gras
    plan.Range("B3:N" & Rows.count).Font.Color = vbBlack
    plan.Range("B3:N" & Rows.count).Font.Bold = False

    ' Affectation à la variable xrgValid de toutes les cellules du tableau contenant une liste déroulante
    Set xrgValid = plan.[B5].SpecialCells(xlCellTypeSameValidation)

    '---------- Calcule le nombre de cellules non vides de la plage ------
    Nbcv = xrgValid.count                                   ' Nombre de cellules de la plage (la plage étant l'ensemble des cellules du tableau ayant une liste déroulante)
    Nbcb = xrgValid.SpecialCells(xlCellTypeBlanks).count    ' Nombre de cellules vides de la plage (la plage étant l'ensemble des cellules du tableau ayant une liste déroulante)
    '-----------------------------------------------------------------

    ReDim t(1 To Nbcv - Nbcb, 1 To 6)
    auxil.Cells.Delete
    For Each x In xrgValid.Cells
        If x.Value <> "" Then
            If x.Offset(-1) <> "" Then
                n = n + 1
                t(n, 1) = x.Column
                t(n, 2) = x.Value
                t(n, 3) = TimeValue(Split(x.Offset(-1), "-")(0))
                t(n, 4) = TimeValue(Split(x.Offset(-1), "-")(1))
                t(n, 5) = x.Row
                t(n, 6) = Format(t(n, 1), "0000") & String(50 - Len(t(n, 2)), " ") & t(n, 2) & Format(t(n, 3), "hhmm") & Format(t(n, 4), "hhmm")
            End If
        End If
    Next x
    auxil.[A1].Resize(n, 6) = t
    auxil.[A1].Resize(n, 6).Sort key1:=auxil.[F1], order1:=xlAscending, MatchCase:=False, Header:=xlNo
    t = auxil.[A1].Resize(n, 5).Value

    ' On supprime la feuille nommée "Auxilxxx"
    On Error Resume Next
    Application.DisplayAlerts = False
    auxil.Delete
    Application.DisplayAlerts = True
    On Error GoTo 0

    For I = 2 To UBound(t)
        If t(I, 1) = t(I - 1, 1) And t(I, 2) = t(I - 1, 2) And t(I, 3) < t(I - 1, 4) Then
            plan.Cells(t(I, 5), t(I, 1)).Font.Color = vbRed
            plan.Cells(t(I, 5), t(I, 1)).Font.Bold = True
            plan.Cells(t(I - 1, 5), t(I - 1, 1)).Font.Color = vbRed
            plan.Cells(t(I - 1, 5), t(I - 1, 1)).Font.Bold = True
            On Error Resume Next
            coll.Add "", t(I, 5) & "/" & t(I, 1)
            coll.Add "", t(I - 1, 5) & "/" & t(I - 1, 1)
            On Error GoTo 0
        End If
    Next I

    ' Nouveau code pour la mise en forme conditionnelle basée sur la liste déroulante
'    Set cellsBtoN = plan.Range("B:N")
    Set cellsBtoN = xrgValid
    If Not Intersect(Target, cellsBtoN) Is Nothing Then
        For Each cell In Intersect(Target, cellsBtoN)
            If cell.Value <> "" Then
                Set cellQ = plan.Columns("S:S").Find(What:=cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
                If Not cellQ Is Nothing Then cell.Interior.Color = cellQ.Interior.Color
            End If
        Next cell
    End If

End Sub
Cliquez pour agrandir...
ça semble en effet fonctionner...merci beaucoup
 
Vote positif 0 Vote négatif

Discussions similaires

N
  • Question
Microsoft 365 Imbrication de deux formule Worksheet_BeforeDoubleClick
Réponses
1
Affichages
153
Nathan027
N
U
  • Question
Autres [RESOLU] Déclaration de variable
Réponses
5
Affichages
207
un internaute
U
N
  • Résolu(e)
Microsoft 365 Ajouter une condition dans une VBA
Réponses
2
Affichages
203
Nathan027
N
T
  • Résolu(e)
XL 2010 VBA - Fonction double clics à opérations multiples
Réponses
2
Affichages
171
Titi456
T
U
  • Question
Autres Comment puis-je m'en sortir?
Réponses
2
Affichages
248
un internaute
U
J
  • Question
XL 2019 recuperer plage de cellule sur feuille differente
Réponses
2
Affichages
352
juju91
J
A
  • Résolu(e)
Microsoft 365 Vider des listes déroulantes en cascade
Réponses
6
Affichages
320
Franc58
F
T
  • Résolu(e)
Microsoft 365 macro sur cellule nom onglet (formule) pour ouvrir l'onglet correspondant
Réponses
8
Affichages
395
Tartineaunut
T
A
  • Question
Microsoft 365 Slicer - supprimer le menu contextuel ou la possibilité de supprimer le filtre
Réponses
1
Affichages
343
xUpsilon
xUpsilon
B
  • Question
XL 2016 RESOLU _ Reset le minuteur si Userform Actif et activité sur Userform
Réponses
14
Affichages
326
Dranreb
Dranreb

Membres actuellement en ligne

20 membres et 91 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 214
Messages
2 086 311
Membres
103 175
dernier inscrit
abcc