Optimisation Code VBA

[djstroubi]

Bonjour,

Je viens d'écrire mes lignes de code pour réaliser un copier coler d'une feuille vers une autres. Dans la feuille, dans laquel j'extrai mes donnée, j'ai des milliers de lignes et le temps que le copie-collé se réalise par le VBA est considérable.

Sub Copy_PasteOpenposition()
'ActiveSheet.Unprotect
 Dim mySource As Range, myselection As Range, myCible As Range, Cell As Range
 
 Dim lg As Integer
 Dim onglet As String
 
 

Set mySource = Sheets("copie").Range("A7:N1000000")
Set myselection = Sheets("copie").Range("C7:C100000")


 lg = 1

 
 For Each Cell In myselection
     If IsEmpty(Cell) Then
          
     Else
        
    onglet = Cell.Value
    ligne = Sheets(onglet).Cells(100000, 2).End(xlUp).Row + 1
        Sheets(onglet).Cells(ligne, 1) = mySource.Cells(lg, 19)
        Sheets(onglet).Cells(ligne, 2) = mySource.Cells(lg, 20)
        Sheets(onglet).Cells(ligne, 3) = mySource.Cells(lg, 21)
        Sheets(onglet).Cells(ligne, 4) = mySource.Cells(lg, 22)
        Sheets(onglet).Cells(ligne, 5) = mySource.Cells(lg, 23)
        Sheets(onglet).Cells(ligne, 6) = mySource.Cells(lg, 24)
        Sheets(onglet).Cells(ligne, 7) = mySource.Cells(lg, 25)
        Sheets(onglet).Cells(ligne, 8) = mySource.Cells(lg, 26)
        Sheets(onglet).Cells(ligne, 9) = mySource.Cells(lg, 27)
        Sheets(onglet).Cells(ligne, 10) = mySource.Cells(lg, 28)
        Sheets(onglet).Cells(ligne, 11) = mySource.Cells(lg, 29)
        Sheets(onglet).Cells(ligne, 12) = mySource.Cells(lg, 30)
        Sheets(onglet).Cells(ligne, 13) = mySource.Cells(lg, 31)
        Sheets(onglet).Cells(ligne, 14) = mySource.Cells(lg, 32)
                
   lg = lg + 1
  
   End If
   
 Next


End Sub

Est ce qu'il y a des moyens de l'optimiser?

Cordialement

 

[gbinforme]

Re : Optimisation Code VBA

Bonsoir,

En espérant que j'ai compris ce que tu veux faire :

Sub Copy_PasteOpenposition()
'ActiveSheet.Unprotect
 Dim myselection As Range, Cell As Range
 Dim ligne As Long

Application.ScreenUpdating = False
Set myselection = Sheets("copie").Range("C7:C100000")
With Sheets("copie")
    For Each Cell In myselection
        If IsEmpty(Cell) Then
            ' pas de copie
        Else
            ligne = Sheets(Cell.Value).Cells(Rows.Count, 2).End(xlUp).Row + 1
            .Range("S" & Cell.Row & ":AF" & Cell.Row).Copy _
                Destination:=Sheets(Cell.Value).Cells(ligne, 1)
        End If
    Next Cell
End With
Application.ScreenUpdating = True
End Sub

 

[ROGER2327]

Re : Optimisation Code VBA

Bonsoir à tous

À essayer :​

Sub Copy_PasteOpenposition()
Dim maSource As Range, maSelection As Range, Cell As Range
Dim lg As Integer
    Set maSource = Sheets("copie").Range("A7:N1000000")
    Set maSelection = Sheets("copie").Range("C7:C100000")
    lg = 1
    With Application: .ScreenUpdating = 0: .EnableEvents = 0: .Calculation = -4135: End With
    For Each Cell In maSelection.Cells
        If Not IsEmpty(Cell) Then
            With Worksheets(Cell.Value)
                .Cells(.Cells(100000, 2).End(xlUp).Row + 1, 1).Resize(1, 14).Value = maSource.Cells(lg, 19).Resize(1, 14).Value
            End With
            lg = lg + 1
        End If
    Next
    With Application: .Calculation = -4105: .EnableEvents = 1: .ScreenUpdating = 1: End With
End Sub

À vue de nez, pas plus de trois secondes pour vingt mille lignes...
Mais en l'absence de support, difficile à dire exactement.​

ROGER2327
#6393

Samedi 21 Décervelage 140 (Chaire du Dr Faustroll - fête Suprême Première seconde)
29 Nivôse An CCXXI, 9,0641h - mercure
2013-W03-5T21:45:14Z

 

[Cousinhub]

Re : Optimisation Code VBA

Bonsoir,

Comme dit par mes illustres collègues ayant déjà répondu, sans base "solide", difficile de répondre...

Cependant, au vu de ton code, je pense qu'un code à base de "Filtre Élaboré" devrait résoudre ton problème en moins de quelques dixièmes de seconde....

Bon courage

 

[Si...]

Re : Optimisation Code VBA

salut

un autre essai, Si... la macro est écrite dans de le Module de la feuille "Copie"

Sub Copy_PasteOpenposition()
   Dim R As Range
   Dim lg As Long
   lg = 6
   For Each R In Range("C7:C100000").SpecialCells(xlCellTypeConstants)
     With Sheets(R.Text)
       lg = lg + 1
       ' ou par égalité si... les formats sont à proscrire
       Cells(lg, 19).Resize(1, 14).Copy .Cells(.Cells(100000, 2).End(xlUp).Row + 1, 1)
     End With
   Next
End Sub

 

[djstroubi]

Re : Optimisation Code VBA

Bonjour,

Merci pour vos réponses aussi rapide. Je test vos solutions et je vous retiens au courant des résultats.
Cordialement

 

[djstroubi]

Re : Optimisation Code VBA

Bonjour,

J'ai tester vos codes et ils fonctionnent tous, cependant, je ne maitrise plus le format des cellules.
Il me transfert toute mes données sous format texte alors que je souhaite avoir mes collonnes 10-11 et 12 en format nombre.
Existe-t-il une option pour cela?
je vous met le code que j'ai garder parce qu'il est le plus rapide.

Sub Copy_PasteOpenposition()
 Dim maSource As Range, maSelection As Range, Cell As Range, val As Range, mafuture As Range
 Dim lg As Integer
 
     Set maSource = Sheets("OPEN POSITIONS").Range("A7:AF1000000")
     Set maSelection = Sheets("OPEN POSITIONS").Range("C7:C100000")
     Set mafuture = Sheets("OPEN POSITIONS").Range("F7:F100000")
     lg = 1
    
    With Application: .ScreenUpdating = 0: .EnableEvents = 0: .Calculation = -4135: End With
    For Each Cell In mafuture.Cells
        If (Not (IsEmpty(Cell))) Then
            If CStr(Cell.Value) = "F" Then
                 With Worksheets(CStr(maSelection.Cells(lg, 1).Value))
                     .Cells(.Cells(100000, 1).End(xlUp).Row + 1, 1).Resize(1, 14).Value = maSource.Cells(lg, 19).Resize(1, 14).Value
                 End With
             End If
             lg = lg + 1
        End If
     Next
     With Application: .Calculation = -4105: .EnableEvents = 1: .ScreenUpdating = 1: End With
 End Sub

Cordialement

 

[Robert]

Re : Optimisation Code VBA

Bonjour le fil, bonjour le forum,

Peut être comme ça (non testé) :

Sub Copy_PasteOpenposition()
Dim maSource As Range, maSelection As Range, Cell As Range, val As Range, mafuture As Range
Dim lg As Integer, dest As Range

With Sheets("OPEN POSITIONS")
    Set maSource = .Range("A7:AF1000000")
    Set maSelection = .Range("C7:C100000")
    Set mafuture = .Range("F7:F100000")
End With
lg = 1
With Application: .ScreenUpdating = 0: .EnableEvents = 0: .Calculation = -4135: End With
For Each Cell In mafuture
    If CStr(Cell.Value) = "F" Then
        With Worksheets(CStr(maSelection.Cells(lg, 1).Value))
            Set dest = .Cells(.Cells(100000, 1).End(xlUp).Row + 1, 1)
        End With
        maSource.Cells(lg, 19).Resize(1, 14).Copy dest
        lg = lg + 1
    End If
   Next
With Application: .Calculation = -4105: .EnableEvents = 1: .ScreenUpdating = 1: End With
End Sub

 

[djstroubi]

Re : Optimisation Code VBA

Bonjour Robert,

voici un petit fichier permettant de mieux visualiser le problème.

cordialement

 

[ROGER2327]

Re : Optimisation Code VBA

Bonjour à tous

(...) je souhaite avoir mes collonnes 10-11 et 12 en format nombre. (...)

Il est assez normal qu'une procédure qui importe des données textuelles livre des données textuelles, et que si on souhaite obtenir des données numériques, alors on importe des données numériques.
Dans le cas d'espèce, essayez =0+K7 en AB7 de l'onglet OPEN POSITIONS, et des formules analogues partout où vous voulez transformer un texte formé de chiffres en un nombre. (testé)
Quant à la procédure du message #8, aucune chance qu'elle fonctionne dans la mesure où elle copie les formules. (testé)​

Bonne journée.



ROGER2327
#6403

Mardi 24 Décervelage 140 (Saint Weidman, patriarche - fête Suprême Quarte)
2 Pluviôse An CCXXI, 6,1402h - mousse
2013-W04-1T14:44:11Z

 

[djstroubi]

Re : Optimisation Code VBA

Merci Roger, merci le fil pour votre aide.

Avec votre contribution, tout fonctionne parfaitement.

Cordialement