Microsoft 365 Gros problème de ralentissement au lancement d'un inputbox

Usine à gaz

XLDnaute Barbatruc
Bonjour à toutes et à tous,
Je vous souhaite une belle journée :)

Je reviens vers nos ténors car j'ai un grave souci :mad:
Notre fichier de travail à toujours eu quelques ralentissement quand nous lançons un inputbox.
Mais depuis quelques temps, ça devient catastrophique.
Notamment au lancement de l'inputbox de recherche.
C'est devenu quasiment permanent ... 10 à 15 minutes d'attente à chaque lancement et ça toute la journée. Cela nous bloque dans notre travail.

A force de recherches, j'ai pensé qu'il s'agissait d'un souci de mémoire.
Selon mes lectures internet, pensant que la mémoire pourrait être libérée au fur et à mesure, j'ai ajouté à la fin des instructions Set ... :"Set ... = Nothing"
Malheureusement sans succès.

En fait, il semblerait que ce soit l'utilisation du Processeur qui soit en cause car
il passe pendant les blocages à plus de 47% d'utilisation alors que normalement il ne dépasse pas les 5%.

Je joins les éléments suivants :
- l'image info disque qui montre un espace libre de 327 Go,
- l'image info du système,
- l'image de l'état du processeur aux moments des bugs de ralentissement,
- le code de l'UserForm de recherche,
VB:
Sub Recherche_youky()
nom = InputBox("Cherche N° Client :" & Chr(10) & "      - Si pas de n°," & Chr(10) & "            - ou erreur n°," & Chr(10) & "                  Recommencez !", "Recherche")
If nom = "" Then
[a6].Select
Sheets("format-numero").Visible = False
Exit Sub
End If
Sheets("format-numero").Range("h3") = ""
  q = ActiveSheet.Index
  For q = q To ActiveSheet.Index + Sheets.Count - 1
    K = (q - 1) Mod (Sheets.Count) + 1
With Sheets(K).UsedRange
Application.ScreenUpdating = False
Range([g2], Cells(Rows.Count, "h").End(xlUp)).Activate
Set C = .Find(nom, LookAt:=xlPart)   'LookAt:=xlpart dans cellule - LookAt:=xlWhole) 'cellule entière
[a1].Activate
If Not C Is Nothing Then
firstAddress = C.Address
Do
On Error Resume Next
Sheets(K).Select
C.Activate
    Application.ScreenUpdating = True
    ActiveWindow.ScrollRow = Selection.Row
    If ActiveSheet.Name = "CopieAppels" Then
    Selection.RowHeight = 50
    End If

    If ActiveSheet.Name = "SuivisAppels" Then
    If Cells(ActiveCell.Row, 7) = C Or Cells(ActiveCell.Row, 8) = C Then

    Rows("6:6").Copy
    Cells(ActiveCell.Row, 1).Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Selection.RowHeight = 300

    End If
    End If
    Cells(ActiveCell.Row, 1).Select

If ActiveSheet.Name = "SuivisAppels" And Cells(ActiveCell.Row, 7) <> C And Cells(ActiveCell.Row, 8) <> C Then
rep = MsgBox(ActiveSheet.Name & " votre N° : " & C & " est absent ! Continuer la recherche ?", 4 + 32, "Sélection")
Sheets("format-numero").Visible = False
Else
rep = MsgBox(C & " : OK dans " & ActiveSheet.Name & Chr(10) & "" & Chr(10) & "Cellule - ligne :  " & C.Address & Chr(10) & Chr(10) & "" & "Continuer la recherche ?", 4 + 32, "Résultat")
End If
If rep = vbNo Then
Application.ScreenUpdating = False
Sheets("format-numero").Visible = False
Exit Sub
End If
Application.ScreenUpdating = False
Sheets("format-numero").Range [h3] = ""
Sheets("format-numero").Visible = False
If ActiveSheet.Name = "CopisAppels" Then
Sheets("SuivisAppels").Select
End If
Application.ScreenUpdating = True
Set C = .FindNext(C)
Loop While Not C Is Nothing And C.Address <> firstAddress
End If
End With
  Next q
MsgBox "Ben NON : y'a pas ou y'a plus !"
Application.ScreenUpdating = False
Sheets("format-numero").Visible = False
End Sub
Profane complet en la matière, je ne sais plus quoi faire.
Auriez-vous des idées, solutions ou pistes vers où me diriger ?

Avec mes remerciements,
Amicalement,
lionel,
 

Pièces jointes

  • infos_disque.jpg
    infos_disque.jpg
    30.6 KB · Affichages: 65
  • infos_systeme.jpg
    infos_systeme.jpg
    105.3 KB · Affichages: 35
  • gestionnaire taches.jpg
    gestionnaire taches.jpg
    127.7 KB · Affichages: 34
Dernière édition:

Staple1600

XLDnaute Barbatruc
Bonsoir le fil

=>Usine à gaz
Il est tout à fait normal qu'une usine à gaz se comporte comme telle, non ? ;)

Et déjà, c'est le contraire qu'il faudrait écrire, non ?
Application.ScreenUpdating = True
(donc False)
Et à la rigueur remettre sur True en toute fin de procédure.
 

Staple1600

XLDnaute Barbatruc
Bonsoir BrunoM45

=>Usine à gaz
Sinon (mais tu devrais le savoir depuis le temps)
Il ouvre Excel
CTRL+N
Il importe l'userform
Il ne garde que trois feuilles
Il les remplit avec des données fictives
(pour aller plus vite avec une tite macro de ce type)
VB:
Sub Pour_test()
[C1:K31].Formula = "=REPT(CHAR(TRUNC(65 + (RAND() * (91 - 65)))),3)&ROW()*COLUMN()"
Sheets(Array("Feuil1", "Feuil2", "Feuil3")).FillAcrossSheets Worksheets("Feuil1").[C1:K31]
For i = 1 To 3
Sheets(i).[B1:B31] = Sheets(i).Name
Sheets(i).[A1:A31] = "=TEXT(ROW(),""000"")&ADDRESS(ROW(),COLUMN(),4)"
Sheets(i).UsedRange = Sheets(i).UsedRange.Value
Next
End Sub

Enfin, si j'étais moi, c'est que je me conseillerai de faire illico presto ;)
 

Usine à gaz

XLDnaute Barbatruc
Bonjour JM, BrunoM45, le Forum,

Hier, je n'ai pas pu revenir sur le fil.
Continuant mes recherches ce matin, j'ai appris qu'on pouvait démarrer excel en mode "sans échec".
Et là, miracle ! plus aucun ralentissement.
Je pense toutefois que le mode sans échec va nous causer des soucis genre codes qui ne s'exécutent pas ou pas bien etc..
Mais en attendant de trouver la solution à mon problème, cela va nous aider.

Dès que j'aurai un petit moment, je ferai un fichier test concernent uniquement le code "complet" qui me pause problème et je le mettrai sur le fil.
Amicalement,
lionel,
 
Dernière édition:

Usine à gaz

XLDnaute Barbatruc
Re-Bonjour,
Voici le fichier test que j'ai préparé.
Soyez indulgent surtout toi JM lol
Le code en cause concerne celui qui concerne la feuille (SuivisAppels) le bouton est entouré en rouge.
Je joins un fichier zippé.
Amicalement,
lionel,
 

Pièces jointes

  • test_isitelProspection_sa2.zip
    984.3 KB · Affichages: 13

Staple1600

XLDnaute Barbatruc
Bonsoir le fil

=>Usine à Gaz
[Pour Infos]
Cela n'a rien d'un rien miracle.
Comme son nom l'indique, le mode sans échec, ouvre Excel dans un mode "optimal" mais dégradé
Les restrictions suivantes s’appliquent au démarrage d’une application Office en mode sans échec :
•Les modèles ne peuvent pas être enregistrés.
•Dans Microsoft Office SharePoint Designer, le dernier site web utilisé n’est pas ouvert.
•Dans Microsoft SharePoint Workspace, les fonctionnalités suivantes sont désactivées : synchronisation, indicateur de présence, notification, messagerie et Planificateur de tâches.
•Les personnalisations de barre d’outils et de commande ne sont pas chargées et les personnalisations ne peuvent pas être enregistrées.
•La liste de corrections automatiques n’est pas chargée et les modifications ne sont pas enregistrées.
•Les documents récupérés ne sont pas ouverts automatiquement.
•Toutes les options de la ligne de commande sont ignorées, sauf /a et /n.
•Des fichiers ne peuvent pas être enregistrés dans le dossier de démarrage alternatif.
•Des préférences ne peuvent pas être enregistrées.
•Les fonctions et programmes supplémentaires ne sont pas chargés automatiquement.
•Des documents à accès restreint ne peuvent pas être créés ou ouverts.

[aparté avant le quart]
j'ai appris qu'on pouvait démarrer excel en mode "sans échec".
Pourtant, j'en parle souvent
Pas plus tard que le 1er février par exemple ;)
Re, Bonsoir eriiiic

[Avec du retard]
Pour démarrer Excel en mode sans échec
touche Windows+R
excel.exe /s
ENTER
 
C

Compte Supprimé 979

Guest
Bonsoir Lionel,

Merci de désactiver la mise en forme du classeur la prochaine fois STP

Le problème avec la recherche, c'est bien quand tu cliques sur ces boutons ?

2021-02-17_18h57_29.png


@+
 

Usine à gaz

XLDnaute Barbatruc
Je précise que pour qu'il soit joignable, je n'ai mis que quelques lignes alors que notre fichier de travail en contient plus de 30000.
Je précise également que sur mon ordi, ça ne "coince" pas mais uniquement sur l'ordi de ma collègue Charlotte.
Je remets les caractéristiques de son ordi en pièces jointes.
lionel,
 

Pièces jointes

  • infos_disque.jpg
    infos_disque.jpg
    30.6 KB · Affichages: 26
  • infos_systeme.jpg
    infos_systeme.jpg
    105.3 KB · Affichages: 26
  • gestionnaire taches.jpg
    gestionnaire taches.jpg
    127.7 KB · Affichages: 26

Staple1600

XLDnaute Barbatruc
Re

=>Usine à gaz
C'est possible d'avoir un vrai fichier exemple?
C'est à dire allégé.
(Plus de 40 modules et environs 50 userforms !!! dans le classeur présent dans le zip)

Donc ne contenant que ce qui est en lien avec la problématique du fil?

NB: Merci également de mettre en commentaire le WorkBook_Open qui veut toucher à mon ruban!!!
:rolleyes:
PS: Heureusement que j'ouvre toujours les classeurs sans activer les macros.


NB: Ce n'est pas ne pas être indulgent que d'être
franc, direct et pragmatique.
;)
 

Staple1600

XLDnaute Barbatruc
Re

=>Usine à gaz
[Pour infos]
La procédure affectée au bouton bordé de rouge ce n'est pas:
Sub Recherche_youky()
mais celle-ci
Code:
Public Sub BoutonRecherche()
If Cells(Rows.Count, "a").End(xlUp)(1).Offset(0, 16) <> "" And [t3] <> "OK" Then
    Blocage
    Exit Sub
        Else
        Application.EnableEvents = False
    Application.ScreenUpdating = False
    '[a6].Select
        SupprimeLignes 'si dernière ligne totalement à remplir
        If [t3] <> "OK" Then
        Exit Sub
        End If
        Application.EnableEvents = False
        Application.ScreenUpdating = False
        
        Application.Calculation = xlManual
        Rows("6:6").Select
        Selection.AutoFilter
        Range("a6").Select
        Range("a7:u" & Range("A" & Rows.Count).End(xlUp).Row).ClearFormats
        Cells(ActiveCell.Row, 1).Select
            With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = 0
            .PatternTintAndShade = 0
            End With
        Range([w7], Cells(Rows.Count, "z").End(xlUp)).ClearFormats
        Range([a7], Cells(Rows.Count, "a").End(xlUp)).RowHeight = 40
        Range([J7], Cells(Rows.Count, "j").End(xlUp)).NumberFormat = "General"
        Range([y7], Cells(Rows.Count, "y").End(xlUp)).NumberFormat = "General"
        Application.Calculation = xlAutomatic
        Remonte
        Application.EnableEvents = False
        Application.ScreenUpdating = False
        End If
            
    DebloqueFeuilles
    Sheets("format-numero").Visible = True
    
        Sheets("format-numero").Select
        Application.EnableEvents = False
        Application.ScreenUpdating = False
        
        Range("H3").Select
'        [h3] = ""
        On Error Resume Next
        With [h3]
            ActiveSheet.PasteSpecial Format:="Texte", Link:=False, DisplayAsIcon:=False
        End With

            On Error Resume Next
            ActiveCell.Replace " ", "", xlPart
            ActiveCell.Replace ".", "", xlPart
            ActiveCell.Replace "-", "", xlPart
            ActiveCell.Replace "/", "", xlPart
            ActiveCell.Replace ";", "", xlPart
            ActiveCell.Replace ",", "", xlPart
            ActiveCell.Replace ":", "", xlPart
            ActiveCell.Replace "_", "", xlPart

'            If [h3] > 1 And [h3] < 100000000# Then
'            [h3].Value = [h3].Value
'            End If
            
            If [h3] > 999999999# Then
            [h3].Value = [h3].Value
            End If
            
            If [h3] > 100000000# And [h3] < 1000000000# Then
            [h3].Value = 33 & [h3].Value
            End If

            [h3].Select
            [h3].Copy

    Sheets("SuivisAppels").Select
    If Cells(Rows.Count, "a").End(xlUp)(1).Offset(0, 17) = "" And [t3] <> "OK" Then
    SupprimeLignes 'si dernière ligne totalement à remplir
    'Application.Calculation = xlAutomatic
    Remonte
    Application.EnableEvents = True
    End If
'----------------------------------------------
Application.ScreenUpdating = False
Application.EnableEvents = False
    Recherche_youky
    Cells(ActiveCell.Row, 7).Select
    ClearClipboard1
'----------------------------------------------
If [as1] = "Haut Bas" Then 'est sur le n°"
    ActiveWindow.ScrollRow = Selection.Row
    Selection.Copy
    [H1].PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    [J1].FormulaR1C1 = "N° Client"
    [AW2].FormulaR1C1 = "=IF(OR(R1C8=RC[-42],R1C8=RC[-41]),1,"""")"
    [AW2].Copy
    [AW3:AW20000].PasteSpecial Paste:=xlFormulas, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    [AW2:AW20000].Copy
    [AW2:AW20000].PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Rows("2:20000").Hidden = True
    On Error Resume Next
    [AW2:AW20000].SpecialCells(xlCellTypeConstants, 1).EntireRow.Hidden = False
    Range("AW2:AW20000").Select
    Selection.ClearContents
    Range("h1").Select
    Selection.ClearContents
    Range("J1").Select
    ActiveCell.FormulaR1C1 = "N° Client"
    Cells(ActiveCell.Row, 1).Select
End If
Application.EnableEvents = False
'Masque boutons si N° dans feuille SuivisAppels
If ActiveSheet.Name = "CopieAppels" Then
Application.EnableEvents = True
Application.ScreenUpdating = True
ActiveSheet.Range("g2:g" & Range("S65536").End(xlUp).Row).SpecialCells(xlVisible).Select
ActiveCell.Select
Dim x As Range
Set x = Sheets("SuivisAppels").Range("g7:h20000").Find(ActiveCell, , xlValues, xlPart, , , False)
If Not x Is Nothing Then 'si trouve
ActiveSheet.Shapes("CopieAppels_Button 1").Visible = False
ActiveSheet.Shapes("CopieAppels_Flèche vers le bas 9").Visible = False
[s1] = "Ci-dessous vos commentaires :" & Chr(10) & _
"Votre N° est également dans votre feuille ""SuivisAppels""" & Chr(10) & _
"Allez dans votre feuille pour le traiter"
End
Else
ActiveSheet.Shapes("CopieAppels_Button 1").Visible = True
ActiveSheet.Shapes("CopieAppels_Flèche vers le bas 9").Visible = True
   [s1] = "La ligne de ce N° n'est pas ou plus dans ""SuivisAppels"". Pour la réintégrer :" & Chr(10) & _
   "1 - Si plusieurs lignes sont affichées pour le même n°, Choisissez en cliquant dans une cellule de la ligne du dernier appel" & Chr(10) & _
   "2 - Clic sur bouton ""Réintègrez votre Appel"", la ligne sera transférée en dernière ligne"
'MsgBox ("IMPORTANT : Si vous quittez CopieAppels avant réintégration, vous devrez refaire votre recherche pour retrouver votre ligne" & nbcel)
CreateObject("Wscript.shell").Popup "Si vous quittez CopieAppels avant réintégration," & Chr(10) & _
"vous devrez refaire votre recherche pour retrouver votre ligne", 1, "IMPORTANT :"
End If
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
'Application.Calculation = xlAutomatic
End Sub
 

Membres actuellement en ligne

Statistiques des forums

Discussions
314 708
Messages
2 112 090
Membres
111 416
dernier inscrit
philipperoy83