Autres Accélération d'une macro

[Webperegrino]

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 :

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

 

[vgendron]

Bonjour

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

sinon. un essai.. à l'aveugle

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]

Le Forum,
Bonjour Vgendron,
Je comprends, mais comme mon fichier 7 850 ko, il va me falloir réaliser un fichier extrait.
Je reviens vers vous si j'arrive à en créer un plus léger, ne contenant pas les données personnelles.
Merci pour votre soutien,
Webperegrino

 

[Webperegrino]

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

 

[Webperegrino]

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]

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

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

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]

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]

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]

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)

 

[Staple1600]

Bonsoir le fil,

Webperegrino

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 ?

Désormais il faut utiliser
[code=vb]
le code de ta macro
[/code]

 

[Webperegrino]

Le Forum, Vgendron, Staple 1600,
Bonjour à vous les experts, vous me rendez bien service, ainsi qu'à ceux qui auront les mêmes soucis et et trouveront les solutions dans cet entretien.
Merci beaucoup : vous avez répondu parfaitement à mes attentes.
Cordialement,
Webperegrino
(Excel 2003)