Macro couper / coller en bas Résolu

Question

Bonjour, 

A l'aide d'internet et de votre forum, j'ai réalisé une macro afin de couper certaines lignes de l'onglet "Data" dans l'onglet "BDD", uniquement si dans la quarantième colonne est inscrit "Terminé!". L'objectif étant d'archiver les lignes qui sont soldés dans un onglet différent.

La macro fonctionnait correctement et assez rapidement, mais je pense que le fait que le fichier contienne de plus en plus de lignes, cela ralenti la macro énormément...

A l'heure actuelle la macro prend trop de temps pour s'exécuter, quelqu'un a-t-il une solution ?

Sub Transfert()reponse = MsgBox("Voulez-vous transférer les retours soldés ?", vbYesNo, "Transfert")If reponse = vbYes ThenApplication.ScreenUpdating = False        Dim iLI As Integer    Dim iRE As Integer    Dim LI As Worksheet    Dim re As Worksheet    Set LI = Worksheets("Data")    Set re = Worksheets("BDD")     iLI = 6     For iLI = 7 To 10000        If LI.Cells(iLI, 40).Text = "Terminé!" Then            LI.Range(iLI & ":" & iLI).Copy re.Cells(Rows.Count, 1).End(xlUp)(2)            LI.Range(iLI & ":" & iLI).Delete            iRE = iRE + 1            iLI = iLI - 1        End If    Next    Else    End IfApplication.ScreenUpdating = TrueEnd Sub

Merci

Julien

Configuration: Windows 7 / Firefox 35.0

Maurice · Answer

Bonjour
donne un model de ton fichier
car il manque des petit truc
A+
Maurice

gbinforme · Answer

Bonjour,

Je te propose de tester de cette façon pour laisser faire la boucle à excel et rester sur la plage utile. 
Sub Transfert()
Dim reponse
Dim iLI As Integer
Dim iRE As Integer
Dim LI As Worksheet
Dim re As Worksheet
Dim elm As Range
    Application.ScreenUpdating = False
    reponse = MsgBox("Voulez-vous transférer les retours soldés ?", vbYesNo, "Transfert")
    If reponse = vbYes Then
        Set LI = Worksheets("Data")
        Set re = Worksheets("BDD")
        For Each elm In LI.UsedRange.Columns(40).Cells
            If elm.Text = "Terminé!" Then
                LI.Rows(elm.Row).Copy re.Cells(Rows.Count, 1).End(xlUp)(2)
            End If
        Next elm
    End If
    Application.ScreenUpdating = True
End Sub

Maurice · Answer

Bonjour

sans ton fichier on ne peux pas savoir car tu a peux etre d'autre macro qui s'active ?
A+
Maurice

gbinforme · Answer

Bonjour, 

Je me doutais bien que l'amélioration ne serait pas spectaculaire, alors en utilisant une autre technique cela devrait mieux aller :

 Sub Transfert()
Dim reponse
Dim iLI As Long
Dim iRE As Long
Dim col As Long
Dim tLI(), tRE()
    Application.ScreenUpdating = False
    reponse = MsgBox("Voulez-vous transférer les retours soldés ?", vbYesNo, "Transfert")
    If reponse = vbYes Then
        tLI = Worksheets("Data").UsedRange.Cells.Value
        ReDim tRE(1 To UBound(tLI), 1 To UBound(tLI, 2))
        iRE = 1
        For iLI = 1 To UBound(tLI)
            If tLI(iLI, 40) = "Terminé!" Then
                For col = 1 To UBound(tLI, 2)
                    tRE(iRE, col) = tLI(iLI, col)
                Next col
                iRE = iRE + 1
            End If
        Next iLI
        With Worksheets("BDD")
            iLI = .Cells(Rows.Count, 1).End(xlUp).Row + 1
            .Cells(.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Resize(UBound(tLI), UBound(tLI, 2)).Value = tRE
        End With
        With Worksheets("Data")
            For iLI = UBound(tLI) To 1 Step -1
                If tLI(iLI, 40) = "Terminé!" Then .Rows(iLI).Delete
            Next iLI
        End With
    End If
    Application.ScreenUpdating = True
    MsgBox iRE - 1 & " lignes transférées"
End Sub

Maurice · Answer

Bonjour
une autre facon on desactive tout car tu a beaucoup de function

Sub Transfert()
Dim iLI As Integer
Dim NmbLig As Integer
Dim Lig As Integer
Dim Reponse As String

Reponse = MsgBox("Voulez-vous transférer les retours soldés ?", vbYesNo, "Transfert")
With Application
   .ScreenUpdating = False
   .EnableEvents = False
   .Calculation = xlManual
End With
   If Reponse = vbYes Then
       With Feuil2
'       With Worksheets("BDD")
          NmbLig = Cells(Rows.Count, 1).End(xlUp).Row
          Lig = .Cells(Rows.Count, 1).End(xlUp).Row + 1
          For iLI = NmbLig To 7 Step -1
             If Cells(iLI, 40).Text = "Terminé!" Then
                 Rows(iLI).Copy
                  .Cells(Lig, 1).PasteSpecial xlPasteValues
                 Rows(iLI).Delete
                 Lig = Lig + 1
             End If
         Next
      End With
   End If
With Application
   .CutCopyMode = False
   .ScreenUpdating = True
   .EnableEvents = True
   .Calculation = xlAutomatic
End With
MsgBox "Transfert Terminé"
End Sub


A+
Maurice

gbinforme · Answer

Bonjour julien, 

Pourtant, j'ai essayé sur le classeur que tu as posté et pour moi c'est pratiquement instantané : 2 secondes !

Oufiz · Answer

J'avais pas attendu la fin de la macro quand j'ai testé sur mon PC, c'est en testant sur le pc d'un collègue que celui-ci m'a dit que ça avait duré plus ou mois 5 à 10 min..

Macro couper / coller en bas

7 réponses

Discussions similaires

Newsletters