Optimisation d'une macro + Application à tous les onglets

**Identifiant75** · 05/05/2015, 11h01

Est ce dû a l'utilisation de tableau ?

**Daniel.C** · 05/05/2015, 11h18

Celle-ci semble fonctionner ?

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
Sub test2()
Dim Tabl As Variant, Plage As Range
Dim inCalculationMode As Integer
Application.ScreenUpdating = False
inCalculationMode = Application.Calculation
Application.Calculation = xlCalculationManual
With ThisWorkbook.Sheets("F2")
    Tabl = Application.Transpose(.Range("A1", .Cells(.Rows.Count, 1).End(xlUp)))
    For i = UBound(Tabl) To 1 Step -1
        Debug.Print Mid(Tabl(i), 16, 1)
        If Mid(Tabl(i), 16, 1) <> "0" Then
            If Plage Is Nothing Then
                Set Plage = Rows(i)
            Else
                Set Plage = Union(Rows(i), Plage)
            End If
        End If
    Next i
    Plage.Delete
End With
Application.Calculation = inCalculationMode
Application.ScreenUpdating = True
End Sub

**Identifiant75** · 05/05/2015, 11h25

Non

Erreur au niveau de "Plage.Delete"
Variable objet ou variable de bloc with non définie.

**joe.levrai** · 05/05/2015, 11h34

Bonjour,

quand on manipule des plages via un tableau portant sur un grand nombre d'items, on est parfois surpris de voir que toute la plage n'a pas été importée dans le tableau

regarde si ton Tableau a bien récupéré l'ensemble des lignes, et que les ressources de ton PC n'ont pas limité l'import

entre la ligne 8 et 9 du code, tu ajoutes ça :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
Msgbox Ubound(Tabl)
Exit Sub

et tu vérifies que le nombre affiché correspond bien à la dernière ligne de ta plage.
J'ai mis une sortie de procédure après le test, ça évite de perdre du temps en laissant toute la procédure s'appliquer

**Daniel.C** · 05/05/2015, 11h47

Ce qui est bien, c'est qu'on en apprend tous les jours : "Transpose" tronque à 65536 enregistrements. Je revois la macro, parce que le test est incorrect et qu'elle est encore longue.

**Identifiant75** · 05/05/2015, 11h49

La msg box ne s'affiche pas, le code ne s'execute même plus partiellement

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
Sub DelEditeur2()
 
Dim Tabl As Variant, Plage As Range
Dim inCalculationMode As Integer
Dim i As Long
Application.ScreenUpdating = False
inCalculationMode = Application.Calculation
Application.Calculation = xlCalculationManual
MsgBox UBound(Tabl)
Exit Sub
With ThisWorkbook.Sheets("F2")
    Tabl = Application.Transpose(.Range("A1", .Cells(.Rows.Count, 1).End(xlUp)))
    For i = UBound(Tabl) To 1 Step -1
        If Mid(Tabl(i), 16, 1) <> "0" Then
            .Rows(i).Delete
        End If
    Next i
End With
Application.Calculation = inCalculationMode
Application.ScreenUpdating = True
 
End Sub

**joe.levrai** · 05/05/2015, 12h04

je parlais de la ligne 8-9 du dernier code de Daniel.C

pour le code que tu nous montres, tu dois insérer les deux lignes entre les lignes 12 et 13, c'est à dire après la ligne

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Tabl = Application.Transpose(.Range("A1", .Cells(.Rows.Count, 1).End(xlUp)))

**Identifiant75** · 05/05/2015, 12h13

Effectivement le tableau s’arrête à 65536

**Daniel.C** · 05/05/2015, 12h32

Teste :

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
Sub test()
Dim Tabl As Variant, Plage As Range, Result() As Date, Ctr As Long
Dim inCalculationMode As Integer
Application.ScreenUpdating = False
inCalculationMode = Application.Calculation
Application.Calculation = xlCalculationManual
With ThisWorkbook.Sheets("F2")
    Tabl = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
    ReDim Result(1 To UBound(Tabl, 1))
    For i = UBound(Tabl) To 1 Step -1
        If Minute(Tabl(i, 1)) Mod 10 = 0 Then
            Ctr = Ctr + 1
            Result(Ctr) = Tabl(i, 1)
        End If
    Next i
    ReDim Preserve Result(1 To Ctr)
    .[A:A].ClearContents
    .[A1].Resize(Ctr) = Application.Transpose(Result())
End With
Application.Calculation = inCalculationMode
Application.ScreenUpdating = True
End Sub

Il ne faut pas qu'il reste plus de 65000 lignes non supprimées sinon, il faudra modifier. Mais teste d'abord.

**Daniel.C** · 05/05/2015, 12h37

PS. Il faudra modifier également en fonction du nombre de colonnes du tableau.

**Identifiant75** · 05/05/2015, 13h42

La macro marche sur la colonne A.

Mon fichier excel est composé de 3 colonnes A,B et C.

Logiquement j'ai rajouté

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
 
.[C:C].ClearContents
.[B:B].ClearContents

Suppression de la totalité des valeurs dans B et C.

Pour réaliser le même filtre que en A il faut que je créer un tableau pour B et C?
Je ne maîtrise pas bien la notion de tableau...

**Identifiant75** · 05/05/2015, 14h01

Mais attention, par exemple: si il y a suppression de A42, B42 et C42 doivent être supprimé aussi...

Ca paraît logique mais je le dis quand même.
Les valeurs sont associées par lignes et doivent le rester après le tri ...

**Daniel.C** · 05/05/2015, 14h17

Voici la macro adaptée pour 3 colonnes. représente-toi un tableau à deux dimensions comme une plage Excel. Si tu veux en savoir plus regarde ici :

http://didier-gonard.developpez.com/...s-tableau-vba/

**joe.levrai** · 05/05/2015, 14h17

Bonjour,

et en évitant d'utiliser Transpose, ça marcherait ?

Comme ça

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
Sub DelEditeur2()
Dim Tabl As Variant, Plage As Range
Dim inCalculationMode As Integer
Dim i As Long
Application.ScreenUpdating = False
inCalculationMode = Application.Calculation
Application.Calculation = xlCalculationManual
 
With ThisWorkbook.Sheets("F2")
    Set Plage = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
    Tabl = Plage
    For i = UBound(Tabl) To 1 Step -1
        If Mid(Tabl(i), 16, 1) <> "0" Then
            .Rows(i).Delete
        End If
    Next i
End With
 
Application.Calculation = inCalculationMode
Application.ScreenUpdating = True
 
End Sub

**Identifiant75** · 05/05/2015, 14h22

Non joe la macro n'est pas fonctionnelle:
Erreur sur :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

If Mid(Tabl(i), 16, 1) <> "0" Then

L'indice n'appartient pas à la selection

Daniel.C , je n'ai pas accès à la macro...
Merci pour le lien.

**joe.levrai** · 05/05/2015, 14h27

Ah oui désolé, il faut spécifier la dimension par cette méthode

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

If Mid(Tabl(i,1), 16, 1) <> "0" Then

ça devrait outrepasser la limitation des 65536

**Daniel.C** · 05/05/2015, 14h30

@joe.levrai : le test fonctionne mal, parce que les cellules ont des valeurs date, donc numériques et non des valeurs texte. Fais un essai manuellement avec STXT.

@Identifiant75 : Oups.

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
Sub test()
Dim Tabl As Variant, Result() As Variant, Ctr As Long
Dim inCalculationMode As Integer
Application.ScreenUpdating = False
inCalculationMode = Application.Calculation
Application.Calculation = xlCalculationManual
With ThisWorkbook.Sheets("F2")
    'charge dans la table "Tabl" (en mémoire) la plage A:C
    Tabl = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 3)
    ReDim Result(1 To 3, 1 To UBound(Tabl, 1))
    For i = 1 To UBound(Tabl)
        If Minute(Tabl(i, 1)) Mod 10 = 0 Then
            Ctr = Ctr + 1
            Result(1, Ctr) = Tabl(i, 1)
            Result(2, Ctr) = Tabl(i, 2)
            Result(3, Ctr) = Tabl(i, 3)
        End If
    Next i
    ReDim Preserve Result(1 To 3, 1 To Ctr)
    .[A:C].ClearContents
    .[A1].Resize(Ctr, 3) = Application.Transpose(Result())
End With
Application.Calculation = inCalculationMode
Application.ScreenUpdating = True
End Sub

**Identifiant75** · 05/05/2015, 14h37

NICKEL !!! temps d’exécution extrêmement rapide ...

Dernière petite chose ...

Pour l'appliquer à tous les onglets de la feuille, une petite astuce ?

**joe.levrai** · 05/05/2015, 14h41

Pour moi ça fonctionne !

j'ai téléchargé ton fichier, j'ai volontairement doublé le nombre de lignes pour en tester 155 000 .. et je n'ai pas touché aux valeurs ou formats des cellules
j'ai mis des vérifications durant la procédure et j'ai bien les résultats escomptés
il ne reste que les lignes du style :

21/06/2014 06:20:00
21/06/2014 06:50:00
21/06/2014 08:10:00

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
Sub DelEditeur2()
Dim Tabl As Variant, Plage As Range
Dim inCalculationMode As Integer
Dim i As Long
Application.ScreenUpdating = False
inCalculationMode = Application.Calculation
Application.Calculation = xlCalculationManual
 
With ThisWorkbook.Sheets("F2")
    Set Plage = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
    Tabl = Plage
    Debug.Print "Nombre de lignes dans la plage : " & ThisWorkbook.Sheets("F2").UsedRange.Rows.Count
    Debug.Print "Nombre de lignes dans le tableau : " & UBound(Tabl)
 
    For i = UBound(Tabl) To 1 Step -1
        If Mid(Tabl(i, 1), 16, 1) <> "0" Then
            j = j + 1
            .Rows(i).Delete
        End If
    Next i
End With
Debug.Print "Lignes Supprimée calculé durant la procédure: " & j
Debug.Print "Vérification des suppressions par soustraction : " & UBound(Tabl) - ThisWorkbook.Sheets("F2").UsedRange.Rows.Count
Debug.Print "Lignes Restantes : " & ThisWorkbook.Sheets("F2").UsedRange.Rows.Count
 
Application.Calculation = inCalculationMode
Application.ScreenUpdating = True
 
End Sub

Fenêtre d'exécution

Nombre de lignes dans la plage : 155004
Nombre de lignes dans le tableau : 155004
Lignes Supprimée calculé durant la procédure: 101503
Vérification des suppressions par soustraction : 101503
Lignes Restantes : 53501