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 Statut Contributeur -
michel_m Messages postés 18903 Statut Contributeur -
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
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:
- Légère modification d'un code pour coller a la suite des valeurs
- Code ascii - Guide
- Comment déverrouiller un téléphone quand on a oublié le code - Guide
- Suivi des modifications word - Guide
- Code puk bloqué - Guide
- Code activation windows 10 - Guide
3 réponses
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
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
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.
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.
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
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
Excuses moi, mais c'est Lundi
Sans boucle et certainement + raide
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