Macro trop longue, simplification

Version imprimable

Bonjour à tous!

J'ai une macro qui fonctionne bien mais est beaucoup trop longue.. (environ 12 secondes)

Ce que je cherche à faire:
1 - Enlever les filtres actifs (sans les supprimer)
2 - Insérer une ligne à la fin du tableau qui recopie les formules de la ligne du dessus
3 - Insérer la valeur "31.12.2020" en colonne 296,
4 - Se positionner sur la colonne 2

Voici mon code :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 Sub Bouton9_Clic() On Error Resume Next Sheets("Feuil1").ShowAllData On Error GoTo 0 Range("A2").Select 'la première cellule de la ligne de titre Selection.End(xlDown).Select 'la dernière cellule de la colonne A avant la cellule vide Selection.EntireRow.Copy Selection.Insert shiftXldown Selection.Offset(1).Select 'positionnement sur la nouvelle ligne For Each c In Intersect(ActiveSheet.UsedRange, Selection.EntireRow) If Left(c.Formula, 1) <> "=" Then c.Value = "" Next Selection = Selection.Offset(-1) + 1 ' incrémentation de la valeur en colonne A Application.CutCopyMode = False Selection.Offset(0, 296).Select Selection.Value = "31.12.2020" Selection.Offset(0, -295).Select End Sub
Voilà si vous avez des idées je suis preneur! Merci

Adrien

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Sub Bouton9_Clic()
Dim LastLig As Long
Dim c As Range
 
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With Worksheets("Feuil1")
    If .FilterMode Then .ShowAllData
    Set c = .UsedRange.Find("*", , , , xlByColumns, xlPrevious)
    If Not c Is Nothing Then
        LastLig = c.Row
        Set c = Nothing
        .Rows(LastLig).Copy .Range("A" & LastLig + 1)
        .Rows(LastLig + 1).SpecialCells(xlConstants).ClearContents
        .Cells(LastLig + 1, 296) = "31.12.2020"
    End If
End With
Application.Calculation = xlCalculationAutomatic
End Sub

12/12/2011, 12h29
defluc

Adresses directement les cellules plutôt qu'utiliser des sélections.
ActiveSheet.Cells(Row, Col)
En première instruction, places

Code:

Application.ScreenUpdating = False

et rétablis cette valeur à True en fin de processus.

L'exécution se fera un un clin d'oeil.
12/12/2011, 13h38
laduche31

Bonjour à vous et tout d'abord merci pour votre aide!

Mercatog votre code ne fonctionne pas, je n'ai pas d'erreurs mais rien ne se passe en fait.

defluc j'ai ajouté les instructions

Code:

Application.ScreenUpdating = False

puis true en fin avec succès.

Cependant je n'ai pas réussi à transcrire les Selection par ActiveSheet.Cells(0, 299) = "31.12.2020"
Ca me met une erreur.

Adrien.
12/12/2011, 13h44
mercatog

laduche31, mon code fonctionne (à moins si tu ne l'as pas adapté).

Dans ton éditeur vba, fais une exécution pas à pas, à l'aide de F8 et regarde ce qui se passe.
12/12/2011, 13h46
laduche31

Ok je regarde à nouveau et je te redis

Merci,

Adrien

EDIT : J'ai compris pourquoi ça ne "marchait pas". En fait plus bas j'ai un deuxième tableau donc la ligne va s'insérer en bas du deuxième tableau.
Je cherche à insérer en fin de 1er tableau, pardon de ne pas avoir précisé.
Serait-il également possible d'incrémenter la valeur en colonne A?
(J'ai des chiffres en colonne A : 127,128,...)

En tout cas niveau rapidité c'est parfait!

Merci!

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Sub Bouton9_Clic()
Dim LastLig As Long
 
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With Worksheets("Feuil1")
    If .FilterMode Then .ShowAllData
    LastLig = .Range("A2").CurrentRegion.Rows.Count + 1
    Set c = Nothing
    .Rows(LastLig).Copy
    .Rows(LastLig + 1).Insert
    Application.CutCopyMode = False
    .Rows(LastLig + 1).SpecialCells(xlConstants).ClearContents
    .Cells(LastLig + 1, 296) = "31.12.2020"
    .Cells(LastLig + 1, 1) = Val(.Cells(LastLig, 1)) + 1
End With
Application.Calculation = xlCalculationAutomatic
End Sub

12/12/2011, 14h05
laduche31

Merci!

Cependant le débogeur me trouve une erreur là :

Code:

.Rows(LastLig + 1).SpecialCells(xlConstants).ClearContents

Adrien

Erreur au cas ou tu n'as pas de données en dur sur la ligne.
Comme ceci, ça va aller

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Sub Bouton9_Clic()
Dim LastLig As Long
 
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With Worksheets("Feuil1")
    If .FilterMode Then .ShowAllData
    LastLig = .Range("A2").CurrentRegion.Rows.Count + 1
    .Rows(LastLig).Copy
    .Rows(LastLig + 1).Insert
    Application.CutCopyMode = False
    On Error Resume Next
    .Rows(LastLig + 1).SpecialCells(xlConstants).ClearContents
    On Error GoTo 0
    .Cells(LastLig + 1, 296) = "31.12.2020"
    .Cells(LastLig + 1, 1) = Val(.Cells(LastLig, 1)) + 1
End With
Application.Calculation = xlCalculationAutomatic
End Sub

12/12/2011, 14h17
laduche31

Ca ne m'insère pas de ligne cette fois-ci,
dans la colonne A deux lignes plus loins j'ai la valeur "1" qui s'insère mais rien de +plus.
12/12/2011, 14h24
defluc

Citation:

Cependant je n'ai pas réussi à transcrire les Selection par ActiveSheet.Cells(0, 299) = "31.12.2020"
Ca me met une erreur.

En openOffice, la valeur minimum de Row et de column est 0 mais en Ms-Office, c'est 1.

Essaies donc avec

Code:

ActiveSheet.Cells(1, 299) = "31.12.2020"
12/12/2011, 14h26
redstoff

Bonjour,

je ne te garatie pas que ca va marcher mais tu peux toujours tester

tu prends la macro que tu as cré au début

juste en dessous du sub, donc en premiere ligne de ta macro, tu mets

Code:

Application.Calculation = xlManual

et en derniere ligne d ela macro tu mets

Code:

Application.Calculation = xlAutomatic

test et dis moi quoi

perso pour moi ca a deja acceleré mes macros
12/12/2011, 14h33
laduche31

Defluc tu as raison c'était ça le problème, ca marche parfaitement maintenant! Merci!

Redstoff j'ai également essayé ta solution et oui ca marche parfaitement! Bon à savoir d'ailleurs! Merci

Mercatog je pense qu'on approchait également du but avec ta solution, merci beaucoup pour ton aide!

A bientôt ! :)

Adrien.
12/12/2011, 14h40
mercatog

Donc je suis obligé de décrire mon fichier sur lequel j'ai fais le test.
Feuille Feuil1
en ligne 2, les titres des colonnes.
en ligne 3, j'ai des valeurs et formules et en A3 j'ai 1.

je lance la macro, j'ai en ligne 4, en A4 j'ai 2, les formules se reportent sans les valeurs en dur.