XL 2016 Limiter le travail d'une macro à des cellules définies

luke3300

XLDnaute Impliqué
Bonsoir le forum,

J'ai un fichier de synthèse qui travaille avec une macro mais qui, depuis le passage à Excel 2016 traîne fortement la patte :( et mets jusqu'à 30 minutes pour s'exécuter.
Ma question est: serait-il possible de modifier la macro pour qu'elle ne tienne compte pour faire la synthèse, que des cellules remplies tant en colonne qu'en ligne.
Par exemple, dans mon fichier test joint, il y a des données à prendre en compte (en en-têtes et en noms) dans les colonnes à partir de la 6 ème jusque la 35 ème et de la ligne 26 à 69. Hors la macro ici est prévue de travailler sur toutes les colonnes de 6 à 106 et les lignes de 26 à 125. Je pense que cela accélérerait aisément le travail si on le limitait aux colonnes et lignes remplies.
Merci au forum d'exister et pour toute l'aide que vous m'apportez.

Excellente soirée par ce temps superbe! :D
 

Pièces jointes

  • Detect Test 1.xlsm
    299.4 KB · Affichages: 30

Lone-wolf

XLDnaute Barbatruc
Bonsoir luke

J'ai vu que dans le fichier tu utilise Do While et Find. Mais il faudrait fare un test comme cet exemple pour voir.

VB:
Application.ScreenUpdating = False
With Sheets("aaa")
set plage = .Range("a6:dd500")
x = 5
     Set c = .Find(valeur à rechercher, , xlValues)
     If Not c Is Nothing Then
        firstAddress = c.Address
        Do
            x = x + 1
         For col = 6 to 105
          .Cells(x, col) = c.Value
         Next col
            Set c =plage .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> firstAddress
      End If
End With

De plus, faut supprimer les Thisworkbook, il sont inutiles puisque tu travail avec ce classeur.
Par exemple : Dim Sh As Worksheet - Set Sh = Sheets("aaa")

With Sh
la macro
End With

Mais je me demande si il y a possibilité d'utilisé les tableaux qui sont plus rapides. Un exemple

tbl = Range("a2: ad200")
lig = plage.Rows.Count: col = plage.Columns.Count
For i = 1 to Ubound(tbl)
If tbl(i, 2) = tbl(i, 5) then
k = k + 1
For j = 1 To col
tablo(k, j) = tbl(i, j)
Next
End If
End If
Next i

Sheets(x).Range("a5").Resize(lig, col) = tablo
 
Dernière édition:
C

Compte Supprimé 979

Guest
Bonjour luke3300, Lone-wolf ;)

Voici le début de ton code
VB:
Private Sub CommandButton2_Click()
  Dim nom As Integer, tachesNouvelles As Integer, tacheAncienne As Range
  Dim colTache As Range, ligneNom As Range, estCapable As Integer
  Dim DerCol As Long, DerNom As Long
  ' Trouver la dernière colonne remplie
  DerCol = Cells(9, Columns.Count).End(xlToLeft).Column
  ' Trouver la dernière ligne en partant du haut : CTRL+Flêche bas
  DerNom = Range("D9").End(xlDown).Row
  '
  For nom = 26 To DerNom  'Les nombres sont à modifier suivant la 1ère et la dernière cellule contenant un nom'
    For tachesNouvelles = 6 To DerCol  'Les chiffres et nombres sont à modifier suivant la 1ère et la dernière colonne contenant les services'

A+
 

Lone-wolf

XLDnaute Barbatruc
Bonjour mapomme :), le Fil, le Forum :)

@mapomme

Ehi! 01:05 du matin c'est "bonjour" non? ;)

En ce qui concerne le fichier, je me disais bien que l'utilisation des tableaux était plus rapide; mais j'ai pas pensé à Dictionnary.

Joli travail ! ;)

EDIT: vu que c'est très rapide 0.11 sec, le screenupdating n'est pas vraiment nécessaire.
 
Dernière édition:

luke3300

XLDnaute Impliqué
Bonjour le forum, Lone-wolf, BrunoM45, mapomme,

Je me suis penché sur vos solutions et voici ce que ça donne:

Code:
Private Sub CommandButton2_Click()
Dim nom As Integer, tachesNouvelles As Integer, tacheAncienne As Range
Dim colTache As Range, ligneNom As Range, estCapable As Integer
Dim DerCol As Long, DerNom As Long
  ' Trouver la dernière colonne remplie
  DerCol = Cells(9, Columns.Count).End(xlToLeft).Column
  ' Trouver la dernière ligne en partant du haut : CTRL+Flêche bas
  DerNom = Range("D9").End(xlDown).Row
  '
  For nom = 26 To DerNom 
    For tachesNouvelles = 6 To DerCol 
        estCapable = 1
        estPartiellementCapable = 0
        Set tacheAncienne = Sheets("Nouveau").Cells(10, tachesNouvelles) 
        With Sheets("Distri")
            While tacheAncienne.Row < 17
                If tacheAncienne.Value <> vbNullString Then
                    Set colTache = .Rows(9).Find(What:=tacheAncienne.Value, LookIn:=xlValues, LookAt:=xlWhole)  'le "9" est le numéro de la ligne contenant les services'
                    Set ligneNom = .Columns(4).Find(What:=Sheets("Nouveau").Range("D" & nom).Value, LookIn:=xlValues, LookAt:=xlWhole)  'La colonne "4" est la colonne contenant les noms'
                    If ligneNom Is Nothing Then
                    estCapable = 0
                    Else
                    If Not colTache Is Nothing Then
                    estCapable = estCapable * IIf(.Cells(ligneNom.Row, colTache.Column).Value = 1, 1, 0)
                    estPartiellementCapable = estPartiellementCapable + IIf(.Cells(ligneNom.Row, colTache.Column).Value = 1, 1, 0)
                    End If
                    End If
                End If
                Set tacheAncienne = tacheAncienne.Offset(1, 0)
            Wend
        End With
        If Sheets("Nouveau").Cells(10, tachesNouvelles).Value = vbNullString Then estCapable = 0  'le chiffre/nombre après ".Cells(" est à modifier suivant la 1ère ligne contenant les anciennes tâches comprises dans les nouveaux services'
        Sheets("Nouveau").Cells(nom, tachesNouvelles).Value = IIf(estCapable = 1, 1, IIf(estPartiellementCapable > 0, 2, ""))
    Next tachesNouvelles
Next nom
MsgBox "Mix des données terminé! ": Exit Sub
End Sub

Je dois dire que ça l'accélère pas mal. :D Seul souci, lorsque je colle le code dans mon bon fichier de travail, la macro continue après la ligne 69 parce qu'il y a des formules jusqu'à la dernière ligne (125). Pourrait-on arrêter la macro sur la ligne avec le dernier résultat affiché?

@Lone-wolf pour ce qui est de:

@luke3300: ajoute Application.ScreenUpdating = False avant les 1ères boucles.

Heuuu ... c'est où? :confused:

@mapomme ta solution est vraiment rapide mais lorsque je la place dans mon bon fichier, elle ne convient pas vu que les noms de la colonne D sont le résultat de formules et la colonne E contient elle aussi des formules. Si on peut surmonter cela, c'est ultra rapide :eek::eek::eek:
Merci à vous et bon vendredi ;)
 

mapomme

XLDnaute Barbatruc
Supporter XLD
Re @luke3300 :),

@mapomme ta solution est vraiment rapide mais lorsque je la place dans mon bon fichier, elle ne convient pas vu que les noms de la colonne D sont le résultat de formules et la colonne E contient elle aussi des formules. Si on peut surmonter cela, c'est ultra rapide :eek::eek::eek:
Merci à vous et bon vendredi


Si tu regardes le code, j'ai mis une remarque à la fin. Je subodorai l'existence de formules donc il faut modifier la dernière partie. J'aurai le temps un peu plus tard dans la journée ou ce soir.
 

luke3300

XLDnaute Impliqué
@Lone-wolf Merci c'est super! Tout marche à merveille hormis un petit jeu de fenêtre qui se produit lorsque la macro travaille. En effet, par 3x sur +/-20 secondes que dure le travail, on voit la fenêtre disparaître et réapparaître. Peut-on améliorer cela?
Je remet le code utilisé sur mon bon fichier:

Code:
Private Sub CommandButton2_Click()
Dim nom As Integer, tachesNouvelles As Integer, tacheAncienne As Range
Dim colTache As Range, ligneNom As Range, estCapable As Integer
ti = Timer
  Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim DerCol As Long, DerNom As Long
  ' Trouver la dernière colonne remplie
  DerCol = Cells(9, Columns.Count).End(xlToLeft).Column
  ' Trouver la dernière ligne en partant du haut : CTRL+Flêche bas
  DerNom = Range("D9").End(xlDown).Row
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  For nom = 26 To DerNom
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
    For tachesNouvelles = 6 To DerCol
        estCapable = 1
        estPartiellementCapable = 0
        Set tacheAncienne = Sheets("Nouveau").Cells(10, tachesNouvelles)
        With Sheets("Dist")
            While tacheAncienne.Row < 17
                If tacheAncienne.Value <> vbNullString Then
                    Set colTache = .Rows(9).Find(What:=tacheAncienne.Value, LookIn:=xlValues, LookAt:=xlWhole)  'le "9" est le numéro de la ligne contenant les services'
                    Set ligneNom = .Columns(4).Find(What:=Sheets("Nouveau").Range("D" & nom).Value, LookIn:=xlValues, LookAt:=xlWhole)  'La colonne "4" est la colonne contenant les noms'
                    If ligneNom Is Nothing Then
                    estCapable = 0
                    Else
                    If Not colTache Is Nothing Then
                    estCapable = estCapable * IIf(.Cells(ligneNom.Row, colTache.Column).Value = 1, 1, 0)
                    estPartiellementCapable = estPartiellementCapable + IIf(.Cells(ligneNom.Row, colTache.Column).Value = 1, 1, 0)
                    End If
                    End If
                End If
                Set tacheAncienne = tacheAncienne.Offset(1, 0)
            Wend
        End With
        If Sheets("Nouveau").Cells(10, tachesNouvelles).Value = vbNullString Then estCapable = 0  'le chiffre/nombre après ".Cells(" est à modifier suivant la 1ère ligne contenant les anciennes tâches comprises dans les nouveaux services'
        Sheets("Nouveau").Cells(nom, tachesNouvelles).Value = IIf(estCapable = 1, 1, IIf(estPartiellementCapable > 0, 2, ""))
    Next tachesNouvelles
Next nom
MsgBox "Mix des données terminé! Merci pour votre patience." & vbLf & vbLf & "Durée: " & Format(Timer - ti, "0.00\ sec.")
  Application.Calculation = xlCalculationAutomatic 'Exit Sub
End Sub

Merciiiiiiiiiii :)
 

Discussions similaires

Statistiques des forums

Discussions
311 715
Messages
2 081 822
Membres
101 821
dernier inscrit
hybroxis