Légère modification d'un code pour coller a la suite des valeurs

Résolu
kgigant Messages postés 223 Statut Membre -  
michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   -
Bonjour,

Je souhaite copier toutes les lignes de la Feuil1 de mon classeur qui ont une valeur en A pour les coller dans la Feuil2 à la suite des valeurs déjà présente.

En cherchant un peu sur tous les forums j'ai trouvé un code qui répond en grande partie à mes attentes sauf qu'il colle les valeurs en début de Feuil2 en décallant les autres.

J'ai tenté quelques modifications afin qu'il colle les valeurs à la suite des lignes existantes, mais je n'ai pas réussit.

voici le code :

Sub a()
Dim Lig As Long
Dim Col As String
Dim NbrLig As Long
Dim NumLig As Long

Sheets("feuil2").Activate ' feuille de destination

Col = "A" ' colonne données non vides à tester'
NumLig = 2 'alors là ca doit etre le N° de la 1er ligne de données en comptant la ligne 1 = 0 .... ? '
With Sheets("feuil1") ' feuille source'
NbrLig = .Cells(65536, Col).End(xlUp).Row
For Lig = 1 To NbrLig 'n° de la 1ere ligne de données'
If .Cells(Lig, Col).Value <> "" Then
.Cells(Lig, Col).EntireRow.Copy
NumLig = NumLig + 1
Sheets("feuil2").Cells(NumLig, 1).Insert Shift:=xlDown
'ici pour insérer ou .Paste pour coller'
End If
Next
End With

End Sub

si quelqu'un à une idée je prends !! Merci de votre aide

3 réponses

  1.
    kgigant Messages postés 223 Statut Membre 9
     
    J'ai ajouter un code et ça à l'air de fonctionner mais j'aimerai bien avoir l'approbation d'une personne pour m'asurer que le code réponds bien à mes attentes.

    Le voici :

    Sub a()
    Dim Lig As Long
    Dim Col As String
    Dim NbrLig As Long
    Dim NumLig As Long

    Sheets("feuil2").Activate ' feuille de destination

    Col = "A" ' colonne données non vides à tester'
    NumLig = 2 'alors là ca doit etre le N° de la 1er ligne de données en comptant la ligne 1 = 0 .... ? '
    With Sheets("feuil1") ' feuille source'
    NbrLig = .Cells(65536, Col).End(xlUp).Row
    For Lig = 1 To NbrLig 'n° de la 1ere ligne de données'
    If .Cells(Lig, Col).Value <> "" Then
    .Cells(Lig, Col).EntireRow.Copy
    NumLig = NumLig + 1
    'Sheets("feuil2").Cells(NumLig, 1).Insert Shift:=xlDown
    'ici pour insérer ou .Paste pour coller'
    Sheets("Feuil2").Select
    Range("A1").Select
    Do While ActiveCell.Value > ""
    ActiveCell.Offset(1, 0).Select
    Loop

    ActiveSheet.Paste

    End If
    Next
    End With

    End Sub
    0
  2. michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
     
    Bonjour,

    Bien compliqué ton code !

    Combien as tu de colonnes à copier dans ta feuille source ?
    0
    1. kgigant Messages postés 223 Statut Membre 9
       
      j'ai les 12 premières colonnes ( de A à L)
      0
  3. kgigant Messages postés 223 Statut Membre 9
     
    le nombre de ligne à copier change tous les jours. je peux en avoir 60 comme je peux en avoir 600.

    Par contre je viens de me rendre compte d'un problème, les quelques lignes que je copie en feuil1 vont s'ajouter à toutes les lignes de la feuil2, cependant j'en ai plus de 1000 du coup le code défile une à une les lignes .... il met donc plusieurs minutes à s'éxecuter.
    0
    1. michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
       
      OK, sois patient
      0
    2. kgigant Messages postés 223 Statut Membre 9
       
      patient pour que tu m'aide ou patient parce on ne peut pas faire mieux (j'en doute) ?
      0
    3. michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
       
      re

      patient pour que tu m'aide
      quand on propose une solution sur un forum, c'est pour aider! ! , la patience c'est pour attendre car on a pas que ça à faire

      Essaies cette macro 
      Sub xxx()
Dim NbrLig As Long, Numlig As Long, Nbre As Long, Col As Byte
Dim Tablo(), Ligvide As Long
Dim Start As Single

Start = Timer
Application.ScreenUpdating = False
With Sheets("feuil1")
     'initialisations
     NbrLig = .Cells(65536, "A").End(xlUp).Row
     Nbre = Application.CountIf(.Range("A2:A" & NbrLig), "*")
     ReDim Tablo(1 To Nbre, 1 To 12)
     Numlig = 1
     'collecte des données à transférer
     For cptr = 1 To Nbre
          Numlig = Columns("A").Find("*", Cells(Numlig, "A"), xlValues).Row
          For Col = 1 To 12
               Tablo(cptr, Col) = Cells(Numlig, Col)
          Next
     Next
End With

With Sheets("feuil2")
     'restitution
     Ligvide = .Cells(65536, "A").End(xlUp).Row + 1
     .Cells(Ligvide, "A").Resize(Nbre, 12) = Tablo
     .Select
End With

Application.ScreenUpdating = True
MsgBox "durée: " & Timer - Start & " .sec."
End Sub
      0
    4. kgigant Messages postés 223 Statut Membre 9
       
      je vais essayer ça, je te retiens au courant.
      Merci en attendant
      0
    5. michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
       
      Excuses moi, mais c'est Lundi

      Sans boucle et certainement + raide 

      Option Explicit

Sub xxx()
Dim NbrLig As Long, Col As Byte
Dim Tablo(), Ligvide As Long
Dim Start As Single

Start = Timer
Application.ScreenUpdating = False
With Sheets("feuil1")
     'initialisations
     NbrLig = .Cells(65536, "A").End(xlUp).Row
    Tablo = .Range("A2:L" & NbrLig).Value
End With

With Sheets("feuil2")
     'restitution
     Ligvide = .Cells(65536, "A").End(xlUp).Row + 1
     .Cells(Ligvide, "A").Resize(UBound(Tablo), 12) = Tablo
     .Range(.Cells(Ligvide, "A"), .Cells(Ligvide + 1000, "A")).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
     .Select
End With

Application.ScreenUpdating = True
MsgBox "durée: " & Timer - Start & " .sec."
End Sub
      0