Navigation

Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter

  1. #1
    Membre du Club
    Homme Profil pro
    Développeur informatique
    Inscrit en
    juin 2015
    Messages
    92
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : Belgique

    Informations professionnelles :
    Activité : Développeur informatique

    Informations forums :
    Inscription : juin 2015
    Messages : 92
    Points : 48
    Points
    48

    Par défaut Problème de performance avec XL 2016

    Bonjour à toutes et tous

    J'ai un sérieux souci de performance avec un fichier XL sous Excel 2016 uniquement.

    Je possède un fichier ayant 6000 ligne et 35 colonnes. Soit pas grand chose. Certains de ces fichiers peuvent contenir jusque 60.000 lignes.

    La macro doit contrôler, pour chaque cellule, si les valeurs sont correctement introduite en fonction de différents paramètres.
    Si ce n'est pas le cas, le système doit mettre le fond de la cellule concernée en rouge.
    Un popup est affiché et montre les lignes et colonnes en erreur.

    Pour toutes les versions d'Excel (2007, 2010 et 2013), le résultat est extrêmement rapide. Comme vous pouvez le voir sur cette vidéo.

    Pour info, avec les deux vidéos, je vous montre la vitesse d'exécution pour les 10 premières lignes du document.

    Vidéo pour Excel 2010: C'est instantané


    Par contre, sous Excel 2016, c'est la catastrophe.
    Vidéo pour Excel 2016:

    Il n'y a pas photo.

    Pour les 6000 lignes, Excel crash. Imaginez pour 60.000 lignes!
    Une fois crashé, je dois attendre ± 15min pour que s'ouvre le fichier.

    J'ai déjà regardé sur le forum et j'ai mis en pratique les différentes idées de chacun d'entre vous. Sans succès.
    Cela me donne l'impression que l'instruction "ScreenUpdating" n'est pas exécuté.

    En début de code, j'ai mis les instructions suivante:
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
     
    ' Augmentation des performances    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Ce que j'aimerais savoir s'il y a des différences avec Excel 2016 à ce niveau?
    Comment puis-je résoudre ce problème?

    Comment fonctionne le système:
    J'ai écris une fonction où je passe par paramètre : le n° de ligne et l'objet de la feuille.

    Je parcours le fichier ligne par ligne.
    J’appelle cette fonction qui me retournera la liste des colonnes en erreur.
    La fonction change la couleur de la cellule en erreur.

    Si quelqu'un parmi vous aurait quelques idées... Cela serait le bienvenu.
    Merci d'avance
    André

  2. #2
    Débutant  
    Avatar de patricktoulon
    Homme Profil pro
    cuisiniste
    Inscrit en
    avril 2009
    Messages
    13 638
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Var (Provence Alpes Côte d'Azur)

    Informations professionnelles :
    Activité : cuisiniste
    Secteur : Bâtiment

    Informations forums :
    Inscription : avril 2009
    Messages : 13 638
    Points : 20 364
    Points
    20 364
    Billets dans le blog
    4

    Par défaut re

    re
    oui c'est pas la premiere fois que l'on vois avec 2016 des lenteurs due a l'acces a la memoire voir a l'acces au object non dispo apres declaration dans VBA

    le code serait le bien venu pour voir si on peut améliorer
    mes fichiers dans les contributions:
    mail avec CDO en vba et mail avec CDO en vbs dans un HTA
    survol des bouton dans userform
    prendre un cliché d'un range

    si ton problème est résolu n'oublie pas de pointer : : ça peut servir aux autres
    et n'oublie pas de voter

  3. #3
    Membre du Club
    Homme Profil pro
    Développeur informatique
    Inscrit en
    juin 2015
    Messages
    92
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : Belgique

    Informations professionnelles :
    Activité : Développeur informatique

    Informations forums :
    Inscription : juin 2015
    Messages : 92
    Points : 48
    Points
    48

    Par défaut Réaction ultra rapide ... Merci

    Bonjour,
    J'aimerais vous remercier d'avance pour votre réaction ultra rapide.

    Par soucis de confidentialité, j'ai retiré certain ligne de code (protection, valeurs particulières)... Mais cela ne gène en rien au fonctionnement.
    Je ne peux pas fournir le fichier lui-même (ordre de mon patron).

    Code principal
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
    101
    102
    103
    104
    105
    106
    107
    108
    109
    110
    111
     
    Sub CreateDocument()
        DeclareSheet
        Dim rw As Long
        Dim rd As Long
        Dim ct As Long
        Dim cl As Integer
        Dim lstrw As Long
        Dim newfeuille As Worksheet
        Dim zone As String
        Dim texte As String
        Dim message As String
        Dim lgne As Long
        Dim MaxEmpty As Integer
        Dim RwEmpty As Integer
        Dim avancement As Double
        Dim tmp As Long
        Dim pk_check As Boolean
        Dim t As Long
        documentChked = False
     
        ' Calcul le nombre de ligne à traiter
     
        lstrw = 2   ' Ligne des titres
        ct = 1      ' pointeur du tableau d'erreur
     
        ReDim ErrTbl(1)   ' Ce tableau (publique) contiendra la liste des numéros de ligne en erreur (utilisé dans une autre macro)
     
        ' Ne sachant pas où se trouve la donnée la plus basse dans le fichier, je dois parcourir chaque colonne (à l'exception de la primary key).
        ' Et je calcule le n° de ligne le plus bas. Je ne peux pas utiliser l'instruction :  Range(Cel).CurrentRegion.End(xlDown).Row
        ' Car cette primary key descend beaucoup plus bas que les données elles-même.
     
        For cl = 3 To 38
            tmp = LstRows(feuille, ColumnLetter(cl))
            If tmp > lstrw Then
                lstrw = tmp
            End If
        Next cl
     
        ' Ce contrôle est pour voir si le fichier est vide ou non (juste les titres)
        If lstrw = 2 Then
            MsgBox "The template is empty. Nothing to do", vbInformation + vbOKOnly, "Remark"
            fg = True
            Exit Sub
        End If
     
        MaxRw = lstrw   ' Sauve le nombre de ligne. Utilisé lors de la génération du nouveau document (dans une autre macro)
     
        ' Initialise la progress bar
     
        Progress_Status.ProgressBar.Width = 10
        Progress_Status.ProgressBar.Visible = True
     
        Progress_Status.StatusMessage.Clear
     
        Progress_Status.lbl_Progress = "0%  Row: 3 on " & lstrw
        Progress_Status.Bt_Close.Visible = False
        Progress_Status.Repaint
     
        ' Evite le "flashing" durant le traitement
     
        DoEvents
        Progress_Status.Show vbModeless
     
        ' Augmentation des performances
     
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
     
     
        message = ""
        avancement = 0  ' calcul de la progress bar
        RwEmpty = 0     ' compteur de ligne vide
        MaxEmpty = 10   ' Je considère la fin du document lorsqu'il y a 10 lignes vide consécutive.
     
        For rw = 3 To lstrw
            ' Contrôle la validité des données de la ligne en cours.
            ckx = checkRow(feuille, rw)
            If Len(ckx) > 0 Then
                ' Ajoute la ligne en erreur dans le popup
                Progress_Status.StatusMessage.AddItem "- There is mistake on row: " & rw & " on following column: " & ckx
     
                ' Ajoute le numéro de la ligne en erreur dans un tableau (utilisé dans une autre macro)
                ErrTbl(ct) = rw
                ct = ct + 1
                ReDim Preserve ErrTbl(ct)
     
                If Len(ckx) = 28 Then
                    RwEmpty = RwEmpty + 1
                    If RwEmpty > MaxEmpty Then
                        Progress_Status.StatusMessage.AddItem "- End of file"
                        Exit For
                    End If
                Else
                    RwEmpty = 0
                End If
                total = total + 1
            End If
     
            ' Remet à jour la progress bar
     
            avancement = (rw - 2) / (lstrw - 2) ' retire les titres
     
            Progress_Status.lbl_Progress = "Progress: " & Int(avancement * 10000) / 100 & "%  Row: " & rw & " on " & lstrw
            Progress_Status.ProgressBar.Width = (avancement * 360)   ' Affiche une progress bar
            Progress_Status.Repaint
     
        Next rw
     
        documentChked = True
    End Sub
    Code de la fonction:
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    Function checkRow(ws As Worksheet, rw As Long) As String
     
        Dim result As String    ' Recevra la liste des colonnes en erreur (lettre de la colonne)
        Dim zone As String
        Dim cel As Range
        Dim contenu As String
     
        result = ""
        cl = 1
        zone = "A" & rw & ":" & ColumnLetter(LstColumn(ws, 2)) & rw
     
        ws.Range(zone).Interior.ColorIndex = xlNone     ' Avant de contrôler la ligne, j'enlève les éventuelles couleur.
     
        chkval = ws.Cells(rw, 1)                                ' primary key (utilisé lors de l'importation dans une base de donnée). Par confidentialité, je ne peux pas en dire plus.
        p = InStr(1, chkval, "//")
     
     
        zone = "B" & rw & ":" & ColumnLetter(LstColumn(ws, 2)) & rw  ' Zone des données sans la primary key
     
        ' Je compte si toutes les cellules contient une valeur. Si c'est le cas, c'est bon. Je sort de la fonction.
     
        If WorksheetFunction.CountA(ws.Range(zone)) = 0 Then
            ws.Cells(rw, 1).Interior.ColorIndex = xlNone
        Else
           ' Je contrôle la validité de la primary key
            If p > 0 Or Right(chkval, 1) = "/" Then
                ws.Cells(rw, 1).Interior.ColorIndex = 40
            Else
                ws.Cells(rw, 1).Interior.ColorIndex = xlNone
            End If
     
            ' Je parcours chaque cellule
     
            For Each cel In ws.Range(zone)
                contenu = CStr(cel.Value)
     
                ' Je recherche, pour certaines cellules, qu'elles soient remplie avec une valeur particulière. 
                ' 
                If contenu = "" Or IsNull(contenu) Then
                    If (cel.Column <> 6 And cel.Column <> 7 And cel.Column <> 8 And cel.Column <> 13 And cel.Column <> 16 And cel.Column <> 18 And cel.Column <> 19 And cel.Column <> 20 And cel.Column <> 21 And cel.Column <> 25 And cel.Column <> 27 And cel.Column <> 28 And cel.Column <> 29 And cel.Column <> 31 And cel.Column <> 32 And cel.Column <> 33 And cel.Column <> 34 And cel.Column <> 35 And cel.Column < 38) Then
                        If cel.Column = 23 Then
                            If Left(cel.Offset(0, -9), 7) = "Pending" Then
                                cel.Value = "N/A"
                            End If
                        ElseIf cel.Column = 36 Then
                            If cel.Offset(0, -21) = "Rejected" Then
                                result = result & " AJ,"
                                cel.Interior.ColorIndex = 40
                            End If
                        ElseIf cel.Column = 37 Then
                            If cel.Offset(0, -8) = "YES" Then
                                result = result & " AK,"
                                cel.Interior.ColorIndex = 40
                            End If
                        Else
                            result = result & ColumnLetter(cel.Column) & ","
                            cel.Interior.ColorIndex = 40
                        End If
                    End If
                End If
                cl = cl + 1
            Next cel
     
        End If
     
        If Len(result) > 0 Then
            checkRow = Left(result, Len(result) - 1) ' J'enlève la dernière virgule de la liste
        Else
            checkRow = ""
        End If
    End Function
    Voilà, si cela peux vous aider.
    Encore merci
    André

  4. #4
    Membre éprouvé Avatar de Patrice740
    Homme Profil pro
    Retraité
    Inscrit en
    mars 2007
    Messages
    537
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 64
    Localisation : France, Gironde (Aquitaine)

    Informations professionnelles :
    Activité : Retraité

    Informations forums :
    Inscription : mars 2007
    Messages : 537
    Points : 996
    Points
    996

    Par défaut

    Bonjour,

    Il y a une différence apparue avec Excel 2013, la nouvelle interface SDI, qui m'a dèja posé problème avec ScreenUpdating = False, c'est peut-être une piste.
    Voir ce fil : https://www.developpez.net/forums/d1.../#post10631486

    Édit : Ton screenupdating ne me semble pas placé au bon endroit
    Cordialement,
    Patrice

  5. #5
    Membre du Club
    Homme Profil pro
    Développeur informatique
    Inscrit en
    juin 2015
    Messages
    92
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : Belgique

    Informations professionnelles :
    Activité : Développeur informatique

    Informations forums :
    Inscription : juin 2015
    Messages : 92
    Points : 48
    Points
    48

    Par défaut Dernière idée ne passe pas

    Bonjour,
    Je viens d'essayer votre idée mais sans succès.

    Par contre, ce que j'aimerais faire:
    Vu que ce qui prend beaucoup de ressources, c'est de manipuler le graphique.
    donc, dans mon esprit, pour chaque erreur trouvée, au lieu de changer la couleur, je remplace par un "flag".
    Une fois le contrôle terminé, je remplace la couleur de toutes les cellules ayant ce flag.

    Je pense que cela pourrait augmenter les performances.

    Mais, comment faire pour sélectionner toutes les cellules "flagées" et remplacer la couleur !

    Merci

  6. #6
    Membre éprouvé Avatar de Patrice740
    Homme Profil pro
    Retraité
    Inscrit en
    mars 2007
    Messages
    537
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 64
    Localisation : France, Gironde (Aquitaine)

    Informations professionnelles :
    Activité : Retraité

    Informations forums :
    Inscription : mars 2007
    Messages : 537
    Points : 996
    Points
    996

    Par défaut

    Citation Envoyé par dede_bo Voir le message
    Bonjour,
    Je viens d'essayer votre idée mais sans succès.
    Je pense qu'il faut placer le screenupdating avant la création du document.

    Vu que ce qui prend beaucoup de ressources, c'est de manipuler le graphique.
    donc, dans mon esprit, pour chaque erreur trouvée, au lieu de changer la couleur, je remplace par un "flag".
    Une fois le contrôle terminé, je remplace la couleur de toutes les cellules ayant ce flag.

    Mais, comment faire pour sélectionner toutes les cellules "flagées" et remplacer la couleur !

    Merci
    If suffit de "mémoriser" toutes les cellules dans un range (avec Union) puis d'appliquer la couleur au Range
    Cordialement,
    Patrice

  7. #7
    Membre du Club
    Homme Profil pro
    Développeur informatique
    Inscrit en
    juin 2015
    Messages
    92
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : Belgique

    Informations professionnelles :
    Activité : Développeur informatique

    Informations forums :
    Inscription : juin 2015
    Messages : 92
    Points : 48
    Points
    48

    Par défaut Pas de différence

    Bonjour,
    Sur l'ordinateur ayant Office 2010, la vitesse à augmenté de 50%. Sur Office 2016... Rien à faire, il n'en veut pas!

    Voici les modifications que j'ai apporté.

    Pour information, j'ai mis : ' ********************************************** entre le code modifié

    1° la partie déclarative
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
     
     ' **********************************************
    Public FileName As String    ' Pour ne plus utiliser "ActiveWorkbook" mais plustôt Workbooks(FileName)
    Public ws As Worksheet      ' J'ai déplacé la déclaration en publique, il n'y a plus qu'une seule déclaration
     ' **********************************************
    Public wb As Workbook
    Public setup As Worksheet
    Public feuille As Worksheet
     
    Public fg As Boolean            ' Avoid redundancy
    Public fgcode As Boolean      ' Accept data from drop down but not manualy
    Public fgSave As Boolean      ' Avoid the saving dialog boxes is showned twice.
     
    Public total As Long            ' Number of rows in error
    Public MaxRw As Long         ' Number of rows to be treated
    Public ErrTbl()                    ' Contains the list of rows in error
    Public documentChked As Boolean ' Flag if the control is performed (true) or not (false)
    2° sur l’évènement On Open
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
     
     Private Sub Workbook_Open()
        ' **********************************************
        FileName = ActiveWorkbook.Name  ' Je récupère le nom du fichier
        ' **********************************************
        fg = True
        fgSave = True
    End Sub
    3° Sur la procédure de contrôle

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
    101
    102
    103
    104
    105
    106
    107
    108
    109
    110
    111
    112
    113
    114
    115
    116
    117
    118
    119
    120
    121
    122
    123
    124
    125
    126
    127
    128
    129
    130
    131
    132
    133
    134
     
    Sub CreateDocument()
        ' J'ai tout déplacé au sommet du code.
     
        ' **********************************************
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
     
        ' Evite le "flashing" durant le traitement
        DoEvents
     
        DeclareSheet
        ' **********************************************
        Dim rw As Long
        Dim rd As Long
        Dim ct As Long
        Dim cl As Integer
        Dim lstrw As Long
        Dim newfeuille As Worksheet
        Dim zone As String
        Dim texte As String
        Dim message As String
        Dim lgne As Long
        Dim MaxEmpty As Integer
        Dim RwEmpty As Integer
        Dim avancement As Double
        Dim tmp As Long
        Dim pk_check As Boolean
        Dim t As Long
        documentChked = False
     
        ' Calcul le nombre de ligne à traiter
     
        lstrw = 2   ' Ligne des titres
        ct = 1      ' pointeur du tableau d'erreur
     
        ReDim ErrTbl(1)
     
        For cl = 3 To 38
            tmp = LstRows(feuille, ColumnLetter(cl))
            If tmp > lstrw Then
                lstrw = tmp
            End If
        Next cl
     
        If lstrw = 2 Then
            MsgBox "The template is empty. Nothing to do", vbInformation + vbOKOnly, "Remark"
            fg = True
            Exit Sub
        End If
     
        MaxRw = lstrw   ' Sauve le nombre de ligne. Utilisé lors de la génération du nouveau document
     
        ' Initialise la progress bar
     
        Progress_Status.ProgressBar.Width = 10
        Progress_Status.ProgressBar.Visible = True
     
        Progress_Status.StatusMessage.Clear
     
        Progress_Status.lbl_Progress = "0%  Row: 3 on " & lstrw
        Progress_Status.Bt_Close.Visible = False
        Progress_Status.Repaint
     
        Progress_Status.Show vbModeless
     
        message = ""
        avancement = 0  ' calcul de la progress bar
        RwEmpty = 0     ' compteur de ligne vide
        MaxEmpty = 10   ' Je considère la fin du document lorsqu'il y a 10 lignes vide consécutive.
     
        For rw = 3 To 10
             ' *****************************************************
            ckx = checkRow(rw)  ' J'ai retiré le passage de paramètre de l'objet feuille
             ' *****************************************************
            If Len(ckx) > 0 Then
                Progress_Status.StatusMessage.AddItem "- There is mistake on row: " & rw & " on following column: " & ckx
                ErrTbl(ct) = rw
                ct = ct + 1
                ReDim Preserve ErrTbl(ct)
                If Len(ckx) = 28 Then
                    RwEmpty = RwEmpty + 1
                    If RwEmpty > MaxEmpty Then
                        Progress_Status.StatusMessage.AddItem "- End of file"
                        Exit For
                    End If
                Else
                    RwEmpty = 0
                End If
                total = total + 1
            End If
     
            ' Remet à jour la progress bar
     
            avancement = (rw - 2) / (lstrw - 2) ' retire les titres
     
            Progress_Status.lbl_Progress = "Progress: " & Int(avancement * 10000) / 100 & "%  Row: " & rw & " on " & lstrw
            Progress_Status.ProgressBar.Width = (avancement * 360)   ' Affiche une progress bar
            Progress_Status.Repaint
     
        Next rw
     
        documentChked = True
     
        ' **********************************************
        ' Remplace le flag par la couleur de fond
     
        With Application.ReplaceFormat.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .color = 255
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
        Cells.Replace What:="CTRL_ERR", Replacement:=Empty, LookAt:=xlWhole, _
            SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
            ReplaceFormat:=True
     
        fg = False
        ' Retire le flag pour ne laisser qu'une cellule vide
        Cells.Replace What:="CTRL_ERR", Replacement:="", LookAt:=xlWhole, _
            SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
            ReplaceFormat:=False
     
        fg = True
     
        ' Augmentation des performances
     
     
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
        ForEachWinDoEvents    ' Code trouvé sur ce forum
        ' **********************************************
    End Sub
    4° la fonction qui contrôle une ligne

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
     
    Function checkRow(rw As Long) As String
        ' Count how much empty cell and put them in red
        ' ---------------------------------------------
     
        ' **********************************************
        Application.ScreenUpdating = False ' Ajouté cette ligne si jamais l'instruction ne serait privée qu'à la procédure
        DeclareSheet
        ' **********************************************
     
        Dim result As String
        Dim zone As String
        Dim cel As Range
        Dim lstcol As String
        Dim contenu As String
     
        ' **********************************************
        Dim fg_bck As Boolean ' Sauvegarde le flag de modification
        Set ws = feuille
        ' **********************************************
        result = ""
        cl = 1
     
        ' **********************************************
        lstcol = ColumnLetter(LstColumn(ws, 2)) ' Évitez d'appeler la fonction plusieurs fois
        zone = "A" & rw & ":" & lstcol & rw
        ' **********************************************
        'Sauvegarde le flag de modification
        fg_bck = fg
     
        ws.Range(zone).Interior.ColorIndex = xlNone
     
        chkval = ws.Cells(rw, 1)
        p = InStr(1, chkval, "//")
     
     
        zone = "B" & rw & ":" & lstcol & rw
        If WorksheetFunction.CountA(ws.Range(zone)) = 0 Then
            ws.Cells(rw, 1).Interior.ColorIndex = xlNone
        Else
     
            If p > 0 Or Right(chkval, 1) = "/" Then
                ws.Cells(rw, 1).Interior.ColorIndex = 40
            Else
                ws.Cells(rw, 1).Interior.ColorIndex = xlNone
            End If
     
     
            fg = False
     
            For Each cel In ws.Range(zone)
                contenu = CStr(cel.Value)
     
                If contenu = "" Or IsNull(contenu) Then
                    If (cel.Column <> 6 And cel.Column <> 7 And cel.Column <> 8 And cel.Column <> 13 And cel.Column <> 16 And cel.Column <> 18 And cel.Column <> 19 And cel.Column <> 20 And cel.Column <> 21 And cel.Column <> 25 And cel.Column <> 27 And cel.Column <> 28 And cel.Column <> 29 And cel.Column <> 31 And cel.Column <> 32 And cel.Column <> 33 And cel.Column <> 34 And cel.Column <> 35 And cel.Column < 38) Then
                        If cel.Column = 23 Then
                            If Left(cel.Offset(0, -9), 7) = "Pending" Then
                                cel.Value = "N/A"
                            End If
                        ElseIf cel.Column = 36 Then
                            If cel.Offset(0, -21) = "Rejected" Then
                                result = result & " AJ,"
                                ' **********************************************
                                cel.Value = "CTRL_ERR"   ' Ajout du flag Erreur
                                'cel.Interior.ColorIndex = 40
                                ' **********************************************
                            End If
                        ElseIf cel.Column = 37 Then
                            If cel.Offset(0, -8) = "YES" Then
                                result = result & " AK,"
                                ' **********************************************
                                cel.Value = "CTRL_ERR"
                                'cel.Interior.ColorIndex = 40
                                ' **********************************************
                            End If
                        Else
                            ws.Unprotect appli & "2016"
                            result = result & ColumnLetter(cel.Column) & ","
                            ' **********************************************
                            cel.Value = "CTRL_ERR"
                            'cel.Interior.ColorIndex = 40
                            ' **********************************************
                        End If
                    End If
                End If
                cl = cl + 1
            Next cel
     
        End If
     
        If Len(result) > 0 Then
            checkRow = Left(result, Len(result) - 1)
        Else
            checkRow = ""
        End If
        ' **********************************************
        ' Restore le flag de modification
        fg = fg_bck
       ' **********************************************
    End Function
    La fonction: DeclareSheet
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
     
    Sub DeclareSheet()
        FileName = ActiveWorkbook.Name
        Set wb = Workbooks(FileName)
        Set feuille = wb.Worksheets("Sheet1")
        Set setup = wb.Worksheets("setup")
    End Sub
    La fonction: ForEachWinDoEvents
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
     
    Sub ForEachWinDoEvents()
        Dim win As Window
     
        For Each win In Application.Windows
            DoEvents
        Next win
    End Sub
    Voilà. Je ne sais plus quoi faire !

    André

  8. #8
    Membre éprouvé Avatar de Patrice740
    Homme Profil pro
    Retraité
    Inscrit en
    mars 2007
    Messages
    537
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 64
    Localisation : France, Gironde (Aquitaine)

    Informations professionnelles :
    Activité : Retraité

    Informations forums :
    Inscription : mars 2007
    Messages : 537
    Points : 996
    Points
    996

    Par défaut

    Bonjour,

    Impossible de donner une réponse précise sans la totalité du code.

    Une seule remarque, au début de la 3° procédure : remplacer DoEvents par ForEachWinDoEvents, car DoEvents n'agit que sur la fenêtre active.

    Indépendamment du problème, je suis surpris par tes variables publiques, je conseille de limiter la portée des variables au strict nécessaire (par exemple les déclaration de procédure API). Il n'est jamais nécessaire de déclarer un Classeur ou une feuille en public, il est préférable de les transmettre en variable locale dans les arguments des procédures.
    Cordialement,
    Patrice

Partager

Partager
  • Envoyer la discussion sur Viadeo
  • Envoyer la discussion sur Twitter
  • Envoyer la discussion sur Google
  • Envoyer la discussion sur Facebook
  • Envoyer la discussion sur Digg
  • Envoyer la discussion sur Delicious
  • Envoyer la discussion sur MySpace
  • Envoyer la discussion sur Yahoo