XL 2016 OPTIMISATION CODE VBA

[sevy1]

Bonjour à tous
J'ai un fichier avec deux onglets le premier est sous forme de plage et le second sous forme de tableau .
Je souhaiterais couper et coller les données de l'onglet 1 vers l'onglet 2 lorsque la date est saisie dans la colonne 13 de l'onglet 1. je ne coupe pas toute la ligne parce que dans l'onglet 2 j'ai 4 colonnes supplémentaires à la fin ou se trouvent les formules.
Mon Problème c'est que le code fonctionne mais il est excessivement lent car j'ai plus de 25000lignes dans l'onglet 1 comment puis-je améliorer ce code pour être rapide. Merci d'avance pour vos propositions

Dim sh1, sh2 As Worksheet
Sub Transfert_Donnees()
    Dim derlig, i, j As Long
    Set sh1 = Feuil4
    Set sh2 = PAYE
    derlig = sh2.Cells(Rows.Count, 1).End(xlUp).Row + 1
    j = sh1.Cells(Rows.Count, 1).End(xlUp).Row
    Application.ScreenUpdating = False
    For i = 2 To j
        If sh1.Cells(i, 9) > 0 Then
            sh1.Range(Cells(i, 1), Cells(i, 13)).Cut sh2.Cells(derlig, 1)
            derlig = derlig + 1
        End If
        Next
        For i = j To 2 Step -1
            If sh1.Cells(i, 1) = "" Then sh1.Range(Cells(i, 1), Cells(i, 13)).Delete shift:=xlUp
        Next
    Application.ScreenUpdating = True
End Sub

 

[Efgé]

Bonjour

Sans exemple difficile de faire des tests.....

On pourrais ne faire qu'une seule boucle au lieu de deux et utiliser des With pour améliorer et la présentation et le temps de traitement:

Dim Sh1 As Worksheet, Sh2 As Worksheet
Sub Transfert_Donnees82()
Dim derlig As Long, i As Long, j As Long

Set Sh1 = Feuil4
Set Sh2 = PAYE
derlig = Sh2.Cells(Rows.Count, 1).End(xlUp).Row + 1
j = Sh1.Cells(Rows.Count, 1).End(xlUp).Row

Application.ScreenUpdating = False
With Sh1
   For i = j To 2 Step -1
       If .Cells(i, 9) > 0 Then
           With .Range(.Cells(i, 1), .Cells(i, 13))
               .Copy Sh2.Cells(derlig, 1)
               .Delete shift:=xlUp
               derlig = derlig + 1
           End With
       End If
   Next
End With
Application.ScreenUpdating = True
End Sub

Ensuite, vraiment déclarer les variables.
En utilisant
Dim derlig , i, j As Long
Seule J est Long, le reste est variant.

Surtout, n'oublies pas les . avant les adresses de cellules, sinon ce sont les cellules de la feuille active qui sont prises en compte et pas la feuille du With....

Mais avec un petit exemple, je pense qu'en passant par un tableau tout devrais aller beaucoup plus vite.

Cordialement

 

[Iznogood1]

Bonjour,

a vue de nez, ce code ne devrait pas prendre trop de temps, sauf s'il y a des formules gourmandes en ressources dans tes feuilles.
Auquel cas, c'est le recalcul de toutes les formules du classeur à chaque suppression de ligne qui fait le délai.

Essaye un
Application.Calculation = xlCalculationManual
en début de code (avant le screenupdating = false par ex)

Sans oublier le
Application.Calculation = xlCalculationAutomatic
en fin de code (avant le screenupdating = true par ex)

Attention,
si la macro plant durant son exécution, le calcul automatique sera désactivé...
-> Tu quittes XL et tu reviens, tes formules ne se mettent plus à jour et tu ne comprends pas pourquoi.

C'est encore pire si tu as refilé le fichier à un collègue...

 

[Efgé]

Bonjour Iznogood1

a vue de nez, ce code ne devrait pas prendre trop de temps,

Sur 25 000 lignes, même sans formules, je suis moins sûr....

Cordialement

 

[sevy1]

Bonjour
Merci déjà pour vos réponses je n ai pas encore pu les tester car je ne suis pas devant mon fichier
Justement le fichier sera utilisé par quelqu'un d'autre pour éviter ce type d'erreur que faut il faire

 

[sevy1]

Bonjour
Voici le petit exemple monté

 

[Efgé]

Bonsoir

Une proposition, sans prendre en compte la feuille Cuisine dont on se demande bien ce qu'elle fait là...

Cordialement

 

[sevy1]

Bonjour merci pour la solution elle est plus rapide maintenant il faut que je l'adapte à mon fichier c est vrai qu'il y a certaines instructions que je ne comprends pas par exemple la première affectation après With base à partir de end (3) pourquoi 3

 

[Efgé]

Bonjour

Pour le (3) :
Les instruction XlDirection peuvent être utilisées avec leurs valeures numérals
3 c'est XlUp

xlToLeft = 1
xlToRight = 2
xlUp = 3
xlDown = 4

Après, si tu butes la dessus, peut être serait il plus simple de fournir un fichier plus près de la réalité.

Cordialement

 

[mapomme]

Bonsoir à tous,

Un essai avec un code (dans module1) un peu plus condensé :

Sub Transfert_Donnees_2()
   Application.ScreenUpdating = False
   If BASE.AutoFilterMode Then BASE.Range("a1").AutoFilter
   BASE.Range("a1").CurrentRegion.AutoFilter Field:=5, Criteria1:="<>"
   BASE.Range("a1").CurrentRegion.Offset(1).Resize(BASE.Range("a1").CurrentRegion.Rows.Count - 1, 5).Copy
   SOLDE.Cells(Rows.Count, "a").End(xlUp).Offset(1).PasteSpecial xlPasteValues
   SOLDE.Range("Tableau2[Date fin]").NumberFormat = "mm/dd/yyyy"
   If BASE.AutoFilterMode Then BASE.Range("a1").AutoFilter
End Sub

ERRATA : la macro copie les lignes mais ne les supprime pas.

 

[mapomme]

Re,

Un essai qui supprime les lignes. La vitesse a été obtenue grâce à un tri sur la colonne des dates. Si le tri est indésirable, m'en informer...

 

[mapomme]

Re,

Si le tri est indésirable, m'en informer...

Une version qui supprime les lignes transférées et qui conserve l'ordre des lignes initiales.

 

[Efgé]

Bonjour à tous, Salut mapomme

@ mapomme
Ta version est plus simple, plus efficace, plus mieux quoi ...

Clairement une meilleure solution.

Cordialement

 

[Efgé]

Re

Une autre version par zone SpecialCells en partant du principe que le fichier de base ne comprend pas de formules en colonne E
Pas certain que ce soit plus rapide....

Sub ParZone()
Dim Rng As Range, SousRng As Range, i&
Application.ScreenUpdating = False
    On Error Resume Next
    With BASE
        Set Rng = .Range(.Cells(2, 5), .Cells(.Rows.Count, 1).End(3)(1, 5)).Cells.SpecialCells(xlCellTypeConstants)
    End With
    For Each SousRng In Rng.Offset(, -4).Areas
        i = i + 1
        If i = 1 Then
            Set Rng = SousRng.Resize(, 5)
        Else
            Set Rng = Union(Rng, SousRng.Resize(, 5))
        End If
    Next SousRng
    With SOLDE
        Rng.Copy .Cells(.Rows.Count, 1).End(3)(2)
    End With
    Rng.Delete (xlUp)
Application.ScreenUpdating = True
End Sub

Cordialement

 

[mapomme]

Bonjour Efgé

@ mapomme
Ta version est plus simple, plus efficace, plus mieux quoi ...

Clairement une meilleure solution.

Alors là, ce n'est pas certain du tout. Ta première version (avec tableaux) est plus rapide que la mienne !

Avec de gros volume de données (ce qui n'est pas le cas ici) j'évite quelquefois d'utiliser des grands tableaux. Mon vieux micro n'ayant que 2 Go de mémoire, j'ai déjà rencontré à l'exécution du code des cas de saturation de la dite mémoire. Bon, me direz-vous, un micro de dix ans ça se change ! C'est pas faux...