Copier Vba Excel

Résolu
lanetmel -  
Bonjour,

J'espère que vous allez bien! Je vous remercie à l'avance de prendre le temps de me lire :)
Voilà': petit problème, Je me suis fais un fichier excel dans lequel dans la feuille "All" j'entre tout les lots que j'ai à faire en production, mon but est de copier parfois en plusieurs fois les infos dans différentes feuilles, selon des critères..Soyez indulgent svp, je suis loin d'être experte.. j'essaie de m'améliorer..

ça fonctionne mais

1- C'est vraiment long
2- Les lignes se copient mais garde la même ligne dans la nouvelle feuille que dans la feuille de données.. je sais pas pourquoi?
3- J'aimerais pouvoir rafaraichir les infos mais qu'elles ne recopient pas le mêmes 2 fois, je sais pas par ou commencer

Je ne suis pas rendu là mais le but ensuite est que quand je vais mettre la date cédulé ça se mettent dans l'horaire.. je le dis juste au cas ou ça chagerait quelque chose dans mon code..

voici mon fichier
https://www.cjoint.com/?0CddTJlc8tT

et voici mon code :

Option Explicit

Sub Copyall()

Dim rclient As Integer ' r pour Range et clients pour client
Dim rall As Integer ' r pour Range et all pour Feuilleall

Dim sall As Worksheet ' s pour Sheets et all pour feuilleall
Dim sclient As Worksheet ' s pour Sheets et client pour client
Dim sàlatternoncédulé As Worksheet ' feuille à latter non cédulé
Dim sdéjàlatté As Worksheet ' feuille déjà latté
Dim scédulé As Worksheet ' feuille cédulé
Dim sàlatter As Worksheet ' feuille à latter
Dim sclient1 As Worksheet ' Feuille app
Dim sclient2 As Worksheet ' feuille Cym
Dim sclient3 As Worksheet ' feuille Gvl
Dim sclient4 As Worksheet ' feuille nor
Dim sclient5 As Worksheet ' feuille Wic
Dim sclient6 As Worksheet ' Feuille Jvl
Dim sclient7 As Worksheet ' Feuille Ali

Set sall = Worksheets("all") ' détermine que S pour sheet et all veut dire Feuil all
Set sclient = Worksheets("amx") ' détermine que S pour sheet et amx veut dire Feuille amx
Set sclient1 = Worksheets("app")
Set sclient2 = Worksheets("cym")
Set sclient3 = Worksheets("gvl")
Set sclient4 = Worksheets("nor")
Set sclient5 = Worksheets("wic")
Set sclient6 = Worksheets("jvl")
Set sclient7 = Worksheets("ALI")
Set scédulé = Worksheets("cédulé")
Set sdéjàlatté = Worksheets("déjà latté")
Set sàlatternoncédulé = Worksheets("à latter non cédulé")

rclient = 2

For rall = 3 To 5000 ' pour Range dans la feuilleall de 3 à 5000
If sall.Cells(rall, 12).Text = "AMX" Then ' Si dans la feuilleall dans les cellules à partir de la ligne 2, dans la colonne 4 si ça donne Amx-???
sall.Range(sall.Cells(rall, 1), sall.Cells(rall, 11)).Copy sclient.Cells(rclient, 1) ' feuilall à partir de la ligne3
rclient = rclient + 1
End If

If sall.Cells(rall, 12).Text = "APP" Then
sall.Range(sall.Cells(rall, 1), sall.Cells(rall, 11)).Copy sclient1.Cells(rclient, 1)
rclient = rclient + 1
End If

If sall.Cells(rall, 12).Text = "CYM" Then
sall.Range(sall.Cells(rall, 1), sall.Cells(rall, 11)).Copy sclient2.Cells(rclient, 1)
rclient = rclient + 1
End If
If sall.Cells(rall, 12).Text = "GVL" Then
sall.Range(sall.Cells(rall, 1), sall.Cells(rall, 11)).Copy sclient3.Cells(rclient, 1)
rclient = rclient + 1
End If
If sall.Cells(rall, 12).Text = "NOR" Then
sall.Range(sall.Cells(rall, 1), sall.Cells(rall, 11)).Copy sclient4.Cells(rclient, 1)
rclient = rclient + 1
End If
If sall.Cells(rall, 12).Text = "WIC" Then
sall.Range(sall.Cells(rall, 1), sall.Cells(rall, 11)).Copy sclient5.Cells(rclient, 1)
rclient = rclient + 1
End If
If sall.Cells(rall, 12).Text = "JVL" Then
sall.Range(sall.Cells(rall, 1), sall.Cells(rall, 11)).Copy sclient6.Cells(rclient, 1)
rclient = rclient + 1
End If
If sall.Cells(rall, 12).Text = "ALI" Then
sall.Range(sall.Cells(rall, 1), sall.Cells(rall, 11)).Copy sclient7.Cells(rclient, 1)
rclient = rclient + 1
End If

If sall.Cells(rall, 10).Text >= "" Then
sall.Range(sall.Cells(rall, 1), sall.Cells(rall, 9)).Copy scédulé.Cells(rclient, 1)
rclient = rclient + 1
End If
If sall.Cells(rall, 10).Text = "" And sall.Cells(rall, 11).Text = "" Then
sall.Range(sall.Cells(rall, 1), sall.Cells(rall, 9)).Copy sàlatternoncédulé.Cells(rclient, 1)
rclient = rclient + 1
End If
If sall.Cells(rall, 11).Text >= "" And sall.Cells(rall, 10).Text >= "" Then
sall.Range(sall.Cells(rall, 1), sall.Cells(rall, 11)).Copy sdéjàlatté.Cells(rclient, 1)
rclient = rclient + 1
End If
Next
Application.CutCopyMode = False
End Sub

merci à l'avance
Mélanie

5 réponses

  • Votes
  • Date
  • Date décroissante
  1. lanetmel Auteur
    Bonjour

    personne a une idée?

    merci à l'avance
    Mélanie
    1. scinarf
      Bonjour,

      Alors on va un peu optimiser tout ça, cela dis c'est pas mal du tout, enfin de mon point de vue.

      Pour commencer on va utiliser un :

      application.screenupdating=false 'juste après le sub copyall()
      cela permet de masquer l'ensemble des changements effectués donc de ne pas les afficher = gain de temps.

      Et a la fin on va utiliser un
      application.screenupdating=true 'on peut réafficher le tout a la fin
      1. scinarf
        J'ai remarqué aussi que ce qui fais perdre du temps c'est la boucle fort qui va jusqu'à 5000.

        Pour corriger cela, on peut affecter une colonne qui détecte si oui ou non la ligne a déjà était reportée quelque part.

        Je suis en train de rédiger un nouveau code pour optimiser le tout

        Petite question : Lorsque aucun client est marqué comment faites vous ? exemple, la ligne 30 de votre fichier
      2. lanetmel Auteur
        Bonjour scinarf

        la ligne 30 vient du fait que j'ai insérer une ligne au milieu au lieu d'écrire à la suite.. la formule pour que le nom du client s'inscrive est déjà dans la colonne L ex : =GAUCHE(D23;3) ..alors si j'entre mes choses à la suite au lieu d'insérer des lignes, il n'y aura pas de problème

        merci beaucoup de prendre le temps de m'aider

        Mélanie
      3. michel_m Contributeur
        Bonjour,

        Pour aller vite compte tenu du nombre de lignes, il vaut mieux peut-^tre mémoriser en RAM la feuille all et restituer.

        des trucs que je ne comprend pas:
        For rall = 3 To 5000 ' pour Range dans la feuilleall de 3 à 5000
        If sall.Cells(rall, 12).Text = "AMX" Then ' Si dans la feuilleall dans les cellules à partir de la ligne 2
        o, part de la ligne 3 ?

        Rclient est incrémenté de 1 à chaque boucle,: si j'ai AMX puis 3 autre clients avant un autre Amx, on va avoir un décalage de 3 lignes dans la feuille AMX ?
      4. lanetmel Auteur
        Bonjour Michel

        oui j'ai un décalage dans mes lignes,.. ce que je voulais faire c'est tout simplement que les lignes se mettent une à la suite de l'autre.. je suis loin d'être experte et de tout comprendre alors je comprennais pas pourquoi mes lignes se décalaient.. J'avais essayer de jouer avec ma ligne rclient = rclient + 1 mais ça n'avait pas marché..

        merci
        Mélanie
      5. lanetmel Auteur
        Et aussi tu as raison pour la ligne 2 de la feuille all.. ça aurait dû être 3
        merci
    2. michel_m Contributeur
      Re,

      Bonjour Scinarf, Excuses moi de ne pas t'avoir salué tout à l'heure

      lanetmel

      Je dois m'absenter 1 heure ou 2
      Ci dessous une proposition partielle qui ne reporte que les clients (amx, app...)
      j'attaque les scédulé, latté... à mon retour

      si tu peux, fais un essai et tu dis... 

      Option Explicit  
Option Base 1  

Sub repartir_all()  
Dim Client As String, cpt_cl As Byte, Nbre As Integer, Cptr As Integer  
Dim Tablo(), Lig As Integer, Col As Byte  

Application.ScreenUpdating = False  

With Sheets("all")  
     For cpt_cl = 1 To 8  
          Client = Choose(cpt_cl, "AMX", "app", "CYM", "GVL", "NOR", "WIC", "JVL", "ALI")  
            
          Nbre = Application.CountIf(.Columns("L"), Client)  
          ReDim Tablo(Nbre, 10)  
          If Nbre > 0 Then  
               Lig = 2  
               For Cptr = 1 To Nbre  
                    Lig = .Columns("L").Find(Client, .Cells(Lig, "L"), xlValues).Row  
                    For Col = 1 To 10  
                         Tablo(Cptr, Col) = .Cells(Lig, Col)  
                    Next  
               Next   
               With Sheets(Client)  
                    Ligvide = Columns("A").Find("", Range("A1")).Row  
                    With .Cells(Ligvide, "A").Resize(Nbre, 10)  
                         .Value = Tablo  
                         .Borders.Weight = xlThin  
                    End With  
               End With  
          End If  
     Next  
       

     '-------- EN ATTENTE  
End With  

End Sub


      Michel
      1. lanetmel Auteur
        Bonjour Michel

        Je te remercie beaucoup pour ton aide.. J'ai essayé ton code mais il ne fonctionne pas..
        premièrement, j'ai ajouté ça
        Dim ligvide As Integer
        Ensuite j'arrêtais à
        ReDim Tablo(Nbre, 10)..
        ça je comprends pas tellement cette ligne là alors je sais pas ce qui va pas..

        merci
        Mélanie
      2. michel_m Contributeur
        Re,

        code testé et OK durée env 0,2 secondes

        Je t'envoie le classeur demain matin 

        Option Explicit
Option Base 1
Dim T_all() As Variant, Lig As Integer, Col As Byte

Sub repartir_all()
Dim Client As String, cpt_cl As Byte, Nbre As Integer, Cptr As Integer
Dim Derlig As Integer
Dim Tablo()
Dim T_deja(), T_noced(), T_cedul()
Dim Cpt_deja As Integer, Cpt_noced As Integer, cpt_cedul As Integer

Dim start As Single
start = Timer

Application.ScreenUpdating = False

With Sheets("all")
     'mémorise la feuille "All" en mémoire RAM
     Derlig = .Range("B" & .Rows.Count).End(xlUp).Row
     T_all = .Range("A1:K" & Derlig).Value
    '--------------- Répartition dans les feuilles Clients
     For cpt_cl = 1 To 8
          Client = Choose(cpt_cl, "AMX", "app", "CYM", "GVL", "NOR", "WIC", "JVL", "ALI")
          Nbre = Application.CountIf(.Columns("L"), Client)
          'collecte des données dans la ligne en cours et mémorisation dans la variable Tablo
          If Nbre > 0 Then
               ReDim Tablo(Nbre, 10)
               Lig = 2
               For Cptr = 1 To Nbre
                    Lig = .Columns("L").Find(Client, .Cells(Lig, "L"), xlValues).Row
                    For Col = 1 To 10
                         Tablo(Cptr, Col) = T_all(Lig, Col)
                    Next
               Next
               'restitution et encadrement dans la feuille clients en cours
               With Sheets(Client)
                    .Range("A2:J5000").Clear
                    With .Cells(2, "A").Resize(Nbre, 10)
                         .Value = Tablo
                         .Borders.Weight = xlThin
                    End With
               End With
          End If
     Next
         
     '--------Collecte données suivant les valeurs ou non valeurs dans colonnes JK
     ReDim T_deja(11, 1)
     ReDim T_noced(9, 1)
     ReDim T_cedul(9, 1)
     For Lig = 3 To UBound(T_all)

           'mémorise données vers feuille "déjà latté"
          If T_all(Lig, 10) >= "" And T_all(Lig, 11) >= "" Then
               Cpt_deja = Cpt_deja + 1
               ReDim Preserve T_deja(11, Cpt_deja)
               For Col = 1 To 11
                    T_deja(Col, Cpt_deja) = T_all(Lig, Col)
               Next
          End If
         
          'mémorise vers à latter non cédulé
          If T_all(Lig, 10) = "" And T_all(Lig, 11) = "" Then
               Cpt_noced = Cpt_noced + 1
               ReDim Preserve T_noced(9, Cpt_noced)
               For Col = 1 To 9
                    T_noced(Col, Cpt_noced) = T_all(Lig, Col)
               Next
          End If
          'mémorise vers cédulé
          If T_all(Lig, 10) = "" Then
               cpt_cedul = cpt_cedul + 1
               ReDim Preserve T_cedul(9, cpt_cedul)
               For Col = 1 To 9
                    T_cedul(Col, cpt_cedul) = T_all(Lig, Col)
               Next
          End If
     Next
     
     '-----------------restitutions et encadrements dans _
                              les feuilles deja latte, non cesdule, cedulé
     Restituer "Déjà latté", Cpt_deja, T_deja, 11
     Restituer "à latter non cédulé", Cpt_noced, T_noced, 9
     Restituer "cédulé", cpt_cedul, T_cedul, 9
End With

Sheets("All").Select
Application.ScreenUpdating = True
MsgBox " Répartition effectuée en " & Timer - start & " .sec"
End Sub

Sub Restituer(onglet, Cptr, Tablo, ColX)
With Sheets(onglet)
          .Range("A3:K5000").Clear
          With .Cells(3, "A").Resize(Cptr, ColX)
               .Value = Application.Transpose(Tablo)
               .Borders.Weight = xlThin
          End With
     End With
End Sub
      3. lanetmel Auteur
        Michel

        Je peux pas mettre une note à ta réponse car tu as écrit la réponse dans les commentaires,,
    3. lanetmel Auteur
      Bonjour Michel

      un mot : Wow.. c'est ultra rapide! Je vais regarder comme il faut si tout se passe comme prévu mais à première vue tout semble parfait!

      Je vérifie le tout et te reviens pour mettre résolu si tout est ok

      merci aussi à Scinarf pour ton aide

      Je vous reviens
      Mélanie
      1. michel_m Contributeur
        Bonjour

        Ci joint le classeur avec des vérifs sur les conditions dans les col J & K
        https://www.cjoint.com/?3CghOjkbvRb

        remarques:
        1/ les feuilles de destinations sont vidées chaque fois que tu appuies sur le bouton "transférer"
        peut-^tre dois tu au contraire cumuler à une nouvelle feuille "all" ? tu dis...
        2/ il n'est pas nécessaire de trier la feuille "all" pour regrouper par client. Si ce tri est effectué avant toute intervention sur la feuille "all", on pourrait alors gagner un peu de temps...si ça t'intéresse, tu dis aussi
        3/ Pour mes stats, merci de me dire la durée sur le classeur réel ( 1089 lignes ?)
      2. scinarf
        Pas de soucis et content que une personne suive d'aussi pret son poste ;)

        Bonne journée
    5. lanetmel Auteur
      Bonjour Michel

      C'est parfait! J'avoue que jamais j'aurais été capable de faire un code comme ça.
      1- non c'est parafit que les feuilles se vident et se remplissent
      2- c'est déjà ultra performant et souvent je trie ma feuille quand même juste pour voir les infos..alors ce n'est pas nécessaire
      3- je n'ai que 120 lignes présentement et tout ce fait en 0.06 sec

      un énorme merci!
      il se peut que je vous reviennent bientôt je vais essayer de travailler pour automatiser mon horaire un peu

      c'est génial des gens comme vous
      Mélanie