Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2016 Exécution lente des macros

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

TooFatBoy

XLDnaute Barbatruc
Du coup, je me classe du côté des cons.


Non, je n'ai rien compris.
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.
 

halecs93

XLDnaute Impliqué
Non, je ne peux pas faire ça, car je ne comprends pas ce que fait la macro Change de ta feuille "Planning".
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
 

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
 

halecs93

XLDnaute Impliqué
oui, c'est la partie qui permet de coloriser la cellule "nom". Vais essayer de regarder ça
 

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.
 

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
 

halecs93

XLDnaute Impliqué
ça semble en effet fonctionner...merci beaucoup
 

Discussions similaires

Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…