Sujet Précédent Sujet Suivant

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

Résolu/Fermé
kgigant Messages postés 202 Date d'inscription lundi 21 mars 2011 Statut Membre Dernière intervention 8 janvier 2014 - Modifié par kgigant le 18/02/2013 à 10:02
michel_m Messages postés 16603 Date d'inscription lundi 12 septembre 2005 Statut Contributeur Dernière intervention 16 décembre 2023 - 19 févr. 2013 à 09:35
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
A voir également:

3 réponses

Réponse 1 / 3
kgigant Messages postés 202 Date d'inscription lundi 21 mars 2011 Statut Membre Dernière intervention 8 janvier 2014 9
18 févr. 2013 à 10:35
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
Réponse 2 / 3
michel_m Messages postés 16603 Date d'inscription lundi 12 septembre 2005 Statut Contributeur Dernière intervention 16 décembre 2023 3 310
18 févr. 2013 à 10:41
Bonjour,

Bien compliqué ton code !

Combien as tu de colonnes à copier dans ta feuille source ?
0
kgigant Messages postés 202 Date d'inscription lundi 21 mars 2011 Statut Membre Dernière intervention 8 janvier 2014 9
18 févr. 2013 à 10:59
j'ai les 12 premières colonnes ( de A à L)
0
Réponse 3 / 3
kgigant Messages postés 202 Date d'inscription lundi 21 mars 2011 Statut Membre Dernière intervention 8 janvier 2014 9
18 févr. 2013 à 10:53
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
michel_m Messages postés 16603 Date d'inscription lundi 12 septembre 2005 Statut Contributeur Dernière intervention 16 décembre 2023 3 310
18 févr. 2013 à 11:08
OK, sois patient
0
kgigant Messages postés 202 Date d'inscription lundi 21 mars 2011 Statut Membre Dernière intervention 8 janvier 2014 9
18 févr. 2013 à 11:17
patient pour que tu m'aide ou patient parce on ne peut pas faire mieux (j'en doute) ?
0
michel_m Messages postés 16603 Date d'inscription lundi 12 septembre 2005 Statut Contributeur Dernière intervention 16 décembre 2023 3 310
18 févr. 2013 à 12:20
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
kgigant Messages postés 202 Date d'inscription lundi 21 mars 2011 Statut Membre Dernière intervention 8 janvier 2014 9
18 févr. 2013 à 12:55
je vais essayer ça, je te retiens au courant.
Merci en attendant
0
michel_m Messages postés 16603 Date d'inscription lundi 12 septembre 2005 Statut Contributeur Dernière intervention 16 décembre 2023 3 310
18 févr. 2013 à 13:48
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

Jeu avec réponses à donner
sylmarco -
bmohr -

4 réponses