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

Résolu
kgigant -  
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 Auteur
    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
    1. michel_m Contributeur
      Bonjour,

      Bien compliqué ton code !

      Combien as tu de colonnes à copier dans ta feuille source ?
      0
      1. kgigant Auteur
        j'ai les 12 premières colonnes ( de A à L)
        0
    2. kgigant Auteur
      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 Contributeur
        OK, sois patient
        0
      2. kgigant Auteur
        patient pour que tu m'aide ou patient parce on ne peut pas faire mieux (j'en doute) ?
        0
      3. michel_m Contributeur
        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 Auteur
        je vais essayer ça, je te retiens au courant.
        Merci en attendant
        0
      5. michel_m Contributeur
        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

    Discussions similaires

    Code source couleur de fond
    Mehdi-Amg

    9 réponses