Autres Accélération d'une macro

Webperegrino

XLDnaute Impliqué
Supporter XLD
Bonjour Le Forum,

Je sais que l'usage de l'expression Tablo() peut grandement accélérer les procédures de recherches et d'extraction.
Mais je ne suis expert dans son utilisation dans la création de mes macros.

Auriez-vous la gentillesse de m'aider pour accélérer la macro suivante ?
Elle me demande 7 minutes et 21 secondes pour étudier 912 cellules d'une feuille et pour y reporter le résultat.
Merci à vous tous pour vos contributions à nous (m') aider à progresser dans le VBAd'Excel.
Webperegrino
(Excel 2003)

Voici sa programmation :
VB:
Private Sub CommandButton2_Click()
Dim col, i, der, lg, lx
Dim start As Single: start = Timer '(*temps de macro)
der = Range("B" & Rows.Count).End(xlUp).Row
[D76:AA143].ClearContents
Application.EnableEvents = False: Application.ScreenUpdating = False
For col = 4 To 27
    lx = 76
    For lg = 6 To der
      If Cells(lg, col).Interior.ColorIndex = xlNone Then
        Cells(lx, col) = Cells(lg, 2): lx = lx + 1
      End If
    Next lg
Next col
[A72].Select
Application.EnableEvents = True: Application.ScreenUpdating = True
MsgBox "C'est fini en :" & Chr(10) & Chr(10) & Timer - start & " secondes", vbInformation, "TEMPS D'EXCÉCUTION"
End Sub
 
Dernière édition:

vgendron

XLDnaute Barbatruc
Bonjour

sans ton fichier en exemple, pas facile de comprendre le besoin

sinon. un essai.. à l'aveugle
VB:
Private Sub CommandButton2_Click()
Application.EnableEvents = False
Application.ScreenUpdating = False

Dim col, i, der, lg, lx
Dim start As Single: start = Timer '(*temps de macro)
Dim tablo() As Range

With ActiveSheet
    der = .Range("B" & .Rows.Count).End(xlUp).Row
    .[D76:AA143].ClearContents
    
    tablo = .Range("D6:AA:" & der).Value
    
    For col = LBound(tablo, 2) To UBound(tablo, 2)
        lx = 76
        For lg = LBound(tablo, 1) To UBound(tablo, 1)
            If .Cells(lg, col).Interior.ColorIndex = xlNone Then
                tablo(lx, col) = tablo(lg, 2)
                lx = lx + 1
            End If
        Next lg
    Next col
End With

Application.EnableEvents = True
Application.ScreenUpdating = True

MsgBox "C'est fini en :" & Chr(10) & Chr(10) & Timer - start & " secondes", vbInformation, "TEMPS D'EXCÉCUTION"
End Sub
 

Webperegrino

XLDnaute Impliqué
Supporter XLD
Le Forum,
Vgendron,
Voici un extrait de mon gros fichier
Surprise : ce léger fichier permet l'exécution de la macro complète en 0,18 seconde, alors que dans mon fichier de 7,8 Mo il me faut attendre plus de 7 minutes !
Pour moi c'est un mystère, alors que la macro y fait la même recherche !
Cordialement,
Webperegrino
 

Pièces jointes

  • RECHERCHE.xls
    50 KB · Affichages: 15

Webperegrino

XLDnaute Impliqué
Supporter XLD
Le Forum,
Vgendron,
Merci pour votre proposition que j'ai placée et appliquée pour mesurer le temps d'exécution.
Malheureusement elle bloque en affichant :
Erreur d'exécution '1004', Erreur définie par l'application ou par l'objet​
et "débogage" va sur la ligne
tablo = .Range("D6:AA:" & der).Value​

Avec la programmation que j'avais faite, en ajoutant au début :
Application.EnableEvents = False: Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual​
... et en plaçant à la fin :
Application.EnableEvents = True: Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic​
... j'ai réussi à faire passer l'exécution à 1,7 seconde : ce qui est déjà un immense progrès par rapport à mes 468 secondes du début !

Je pense que cette discussion avance très bien et va servir à beaucoup de personnes ; merci Vgendron, de m' (nous)éclairer.
Cordialement,
Webperegrino
 

vgendron

XLDnaute Barbatruc
Re,

voici deux macros
la première sert à mettre des 1 dans les cellules colorées de ton tableau
l'idée serait de mettre des 1 dans ton tableau plutot que colorer la cellule
et une MFC colore la cellule quand il y a 1

VB:
Sub insertValInTab()

With ActiveSheet
    fin = .Range("B" & .Rows.Count).End(xlUp).Row
    For i = 6 To fin
        For j = 4 To 27
            If .Cells(i, j).Interior.ColorIndex <> xlNone Then .Cells(i, j) = 1
        Next j
    Next i
End With
End Sub

la seconde, fait l'extract
VB:
Sub ExtractVide()
Application.EnableEvents = False
Application.ScreenUpdating = False

Dim col, i, der, lg, lx
Dim start As Single: start = Timer '(*temps de macro)
Dim tablo() As Variant
Dim tabRes() As Variant

With ActiveSheet
    .[D76:AA143].ClearContents 'cette ligne sera certainement à adapter dans ton fichier final
    fin = .Range("B" & .Rows.Count).End(xlUp).Row

    tablo = .Range("B6:AA" & fin).Value
   
    For j = LBound(tablo, 2) + 2 To UBound(tablo, 2)
        tot = 1
        For i = LBound(tablo, 1) To UBound(tablo, 1)
            If tablo(i, j) = "" Then
                ReDim Preserve tabRes(tot)
                tabRes(tot) = tablo(i, 1)
                tot = tot + 1
            End If
        Next i
        .Cells(76, j + 1).Resize(UBound(tabRes), 1) = Application.Transpose(tabRes) 'cette ligne sera certainement à adapter dans ton fichier final
    Next j
End With

Application.EnableEvents = True
Application.ScreenUpdating = True

MsgBox "C'est fini en :" & Chr(10) & Chr(10) & Timer - start & " secondes", vbInformation, "TEMPS D'EXCÉCUTION"
End Sub
 

Webperegrino

XLDnaute Impliqué
Supporter XLD
Le Forum,
VGendron,
Merci Vgendron pour cette dernière approche,
J'ai toutefois une contrainte : dans ce "tableau des indisponibilités en gris", cette macro doit me donner la liste, pour chaque colonne, des personnes disponibles lorsqu'on a rencontré les cellules vides et donc non colorées.
Je pensais que mettre des "1", pour indiquer qu'il y a disponibilité, cela allait alourdir le tableau à la lecture et je désirais le garder le plus sobre possible.

Je vais me pencher sur ta macro Sub ExtractVide(), elle m'intéresse pour me perfectionner en VBA mais j'ai actuellement une toute autre contrainte : tondre une pelouse bien garnie, et mes macros d'Excel sont inopérantes pour ce genre de tâche :)

Je te félicite encore pour tes aides si rapides.
Cordialement aussi à tous les "Barbatruc" : ce Forum est merveilleux.
Webperegrino
 

Webperegrino

XLDnaute Impliqué
Supporter XLD
Le Forum,
Vgendron,
Bonjour
Les deux macros que tu as placées en # ont été exécutées avec succès.
0,94 s d'exécution pour la seconde : c'est révolutionnaire pour ce fichier qui le faisait en 441 s au début !
Merci.

Dernière intervention avant de clôturer cette conversation :
Les résultats s'affichent seulement à partir de la ligne 77....
Comment corriger la macro "ExtractVide" pour que l'affichage s'applique dès la cellule D76, et sans y perdre ses conditions de choix de bordures dans la zone D76:AA76 devenue vide ?

Enfin, en #1, [highlight=vba] macro [/highlight] n'a pas réussi à présenter la macro comme dans les #suivantes : comment y remédier s'il vous plait ?
Merci encore Vgendron pour cette excellente accélération,
Webperegrino
 

Webperegrino

XLDnaute Impliqué
Supporter XLD
Le Forum,
VGendron,
Bonsoir, je pense avoir trouvé la solution.
Il suffit de faire la correction des deux lignes ci-après.
La 2ème macro "ExtractVide" est alors efficace à 100 % :

- fin = .Range("B" & .Rows.Count).End(xlUp).Row + 1 ' j'ai ajouté " + 1"

et
- tot = 0 ' et non pas 1

Cordialement,
Webperegrino
(Excel 2003)