Copier ligne sans écraser les déjà existante Fermé

Question

Bonjour,

Je cherche à copier des lignes d'un onglet vers un autre sans écraser les données existantes.

Ma prog fonctionne très bien mais que pour une seule ligne à copier.
Dès que j'ai plus d'une ligne à copier, celles-ci se copient bien sur la première ligne vide mais en copiant toutes mes lignes sur une seule. Donc je ne vois que la dernière ligne à copier.

ub Macro2()

    Dim Lig As Long
    Dim Col As String
    Dim NbrLig As Long
    Dim NumLig As Long
    Dim r As Long
      
    
    Sheets("Archivage").Activate
    
    Col = "K"
    r = Range("A65536").End(xlUp).Row + 1
    NumLig = 1
    With Sheets("Liste SR")
    NbrLig = .Cells(65536, Col).End(xlUp).Row
    For Lig = 1 To NbrLig
        If .Cells(Lig, Col).Value = "O" Then
            .Cells(Lig, Col).EntireRow.Copy
            NumLig = NumLig + 1
            Cells(r, 1).Select
            ActiveSheet.Paste
            End If
    Next
    End With
    
Sheets("Liste SR").Activate

Dim K As Long
Dim Plage As Range
Set Plage = Range("K:K")
For K = Plage.Cells.Count To 1 Step -1
    If Plage.Cells(K).Value = "O" Then
        Plage.Cells(K).EntireRow.Delete
    End If
Next
MsgBox ("ARCHIVAGE EFFECTUE")
End Sub

Merci pour votre aide

Mike-31 · Answer

Salut,

Testes cette macro, qui sur la feuille Liste SR lance une recherche de cellule valide à partir de la cellule A50, sélectionne la première cellule valide à la cellule U2 et met cette sélection en position copier
passe sur la feuille Archive recherche la première cellule valide et copie à la suite, revient feuille Liste SR et efface la sélection on pourrai mette un enregistrement pour finir.
On en reparle en debut d'après midi

Sub test()
  Range("A50").Select
   Do While ActiveCell.Value = ""
    ActiveCell.Offset(-1, 0).Range("A1").Select
   Loop
    Range("U2", ActiveCell).Select
    Selection.Copy
  Sheets("Archivage").Activate
  Range("A50").Select
   Do While ActiveCell.Value = ""
    ActiveCell.Offset(-1, 0).Range("A1").Select
   Loop
  ActiveCell.Offset(1, 0).Range("A1").Select
  ActiveSheet.Paste
  Range("A2").Select
   Sheets("Liste SR").Activate
   Application.CutCopyMode = False
    Selection.ClearContents
    Range("A2").Select
End Sub


A+

Tranquillou · Answer

Tout d'abord merci. Moi qui pensait qu'il me manquait qu'une ou deux lignes de prog......
Je vois çà et je te tiens au courant dans la prochaine heure. Besoin du fichier ?

Tranquillou · Answer

J'ai testé mais cela ne correspond pas à mon besoin.

Le but étant de sélectionner dans "Liste SR" les lignes dont la colonne K est renseigné par un "O" (Cela fonctionne avec mon développement).

Ensuite les "couper/coller" dans l'onglet "Archive" les unes à la suite des autres sans écraser l'historique déjà "coller".

Et donc mon souci est que si dans "Liste SR" je n'ai qu'une seule ligne renseignée par un "O" cela fonctionne parfaitement avec mon développement. L'unique ligne se colle bien à la suite des précédentes.

Le souci viens lorsque j'ai plusieurs lignes renseignées par un "O".
Ex: J'ai 3 lignes renseignées par un "O". Et bien la première des lignes va bien se copier sous mes données déjà présentes, mais ma deuxième lignes "O" viens écraser cette première et la 3ème écrase la deuxième qui a écrasé la 1er.
Donc je ne vois que la dernière ligne qui elle-même s'est bien positionnée. 

Est-ce clair ?

Mike-31 · Answer

Salut,

J'ai bien compris ton problème, mon code doit parfaitement te convenir en l’adaptant. mais dans ta colonne K les cellules renseignées par un O sont elles contigües ou non 

Le plus simple est que tu mettes à notre disposition un exemple de fichier sans notes confidentielles de façon à écrire un code adapté à ton problème 
Avec ce lien

https://www.cjoint.com/

et sur ton prochain post donnes nous le lien généré pour que l’on puisse le récuper

A+

Tranquillou · Answer

Ok merci mais par contre donne moi ton mail afin que je puisse t'envoyer ce fichier car il fait plus de 3Mo.
Merci encore.

Mike-31 · Answer

même si ton fournisseur d'accès n'est pas free, fais ce qui suit  et colle le lien généré dans un message privé en cliquant sur mon pseudo et message privé

Dans la barre URL tu saisis

https://portail.free.fr/ 

2/ En haut à droite cliquer sur envoi de gros fichiers 
3 Fichier à envoyer faire parcourir et sélectionner le fichier à envoyer 
4/ Me notifier du lien par email saisir son adresse mail afin que free te notifie du lien 
5/ si tu veux protéger ton fichier saisie un mot de passe 
6/ envoyer 
Tu recevras de free un mail te donnant l’adresse pour récupérer ton envoi et éventuellement le supprimer après réception de l’envoi par tes correspondants. 
Il ne suffit plus que d’envoyer a tes correspondants l’adresse du lien et le mot de passe pour y accéder si tu en a saisie un. 
L’intérêt de cette méthode est de ne pas être obligé de réduite la taille d'un fichier ou la définition de photos par exemple et la démarche est anonyme

Tranquillou · Answer

Merci pour la procèdure.
Fait.
http://dl.free.fr/getfile.pl?file=/s3Dg6Qrr

Mike-31 · Answer

.Salut,

Récupères le fichier avec le lien ci-dessous

http://dl.free.fr/getfile.pl?file=/A18xPgQP

Ne touche pas à la cellule K1 dans laquelle j'ai placé une formule pour gérer mon code.

Testes le fichier dans tous les sens et on en reparle, ma macro est nommée test

1/ la macro archives les lignes avec un O en colonne K et s'exécute autant de fois qu'elle rencontre des O
2/ aprés archivage elle supprime les lignes vides
3/ elle recrée les lignes supprimées jusqu'a la ligne 850 (à voir jusqu'ou tu souhaites aller)
4/ elle restaure les formules en colonne K et M des lignes remplacées

Il reste peut être à intégrer dans le code une protection avec mot de passe de la feuille Achives (à voir ainsi que du module macro)

lorsque nous aurons terminé, je te détaillerai chaque ligne du code

A+

lermite222 · Answer

Bonjour,
Tu a oublié...      r=r+1
A+

Mike-31 · Answer

Salut Tranquillou,

Tu peux télécharger mon exemple sur le post 8 pour voir comment fonctionnent les macros.
Mais ce matin j'ai un peu de temps, j'ai revu tout le code pour avoir le même résultat et plus rapide,

La macro se limite au code ci-dessous que tu peux tester en copiant dans le module, affecte le a un bouton et on en reparle en fin de matinée pour affiner tes besoins

Sub test2()

    Dim Lig As Long
    Dim Col As String
    Dim NbrLig As Long
    Dim NumLig As Long
    Dim r As Long
    Sheets("Archivage").Activate
    Col = "K"
    r = Range("A65536").End(xlUp).Row + 1
    NumLig = 1
    With Sheets("Liste SR")
    NbrLig = .Cells(65536, Col).End(xlUp).Row
    For Lig = 1 To NbrLig
        If .Cells(Lig, Col).Value = "O" Then
          .Cells(Lig, Col).EntireRow.Cut
          
          NumLig = NumLig + 1
            Cells(r, 1).Select
            r = r + 1
            ActiveSheet.Paste
            End If
    Next
    End With
    
 Sheets("Liste SR").Activate
Range("A1:A65536").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

Range("A3:M3").Select
    Selection.Copy
    Range("A3:M850").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
        
    Range("K3:M3").Select
    Selection.Copy
    Range("K3:M850").Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Range("A2").Select
    Application.CutCopyMode = False
MsgBox ("ARCHIVAGE EFFECTUE")
End Sub

lermite222 · Answer

Re bonjour à tous,
un petit "essais" plus cour ?
Sub Macro2()

Dim Lig As Long
Dim LigFinA As Long
Dim Col As Integer
Dim NbrLig As Long
Dim FL1 As Worksheet

    Set FL1 = Sheets("Archivage")
    Col = 11
    LigFinA = FL1.Range("A65536").End(xlUp).Row + 1
    With Sheets("Liste SR")
        NbrLig = .Cells(65536, Col).End(xlUp).Row
        For Lig = NbrLig To 1 Step -1
            If .Cells(Lig, Col).Value = "O" Then
                .Rows(Lig).Copy FL1.Rows(LigFinA)
                .Rows(Lig).Delete
                LigFinA = LigFinA + 1
            End If
        Next
    End With

    MsgBox ("ARCHIVAGE EFFECTUE")
End Sub

A+

lermite222 · Answer

Rectificatif, la macro précédante copie à "l'enver"
Sub Macro3()

Dim Lig As Long
Dim LigFinA As Long
Dim Col As Integer
Dim NbrLig As Long
Dim FL1 As Worksheet
Const PremLig = 3 'Première ligne à traiter
    Set FL1 = Sheets("Archivage")
    Col = 11
    LigFinA = FL1.Range("A65536").End(xlUp).Row + 1
    With Sheets("Liste SR")
        NbrLig = .Cells(65536, Col).End(xlUp).Row
        For Lig = PremLig To NbrLig
            If .Cells(Lig, Col).Value = "O" Then
                .Rows(Lig).Copy FL1.Rows(LigFinA)
                .Rows(Lig).Delete
                LigFinA = LigFinA + 1
                Lig = Lig - 1
            End If
        Next
    End With

    MsgBox ("ARCHIVAGE EFFECTUE")
End Sub

Celle-ci copie à "l'endroit" :-)
PS: Un petit conseil, essaye d'éviter des variables qui ne veulent rien dire, genre r, emploi plutôt des variables significatives ce sera beaucoups plus facile à suivre. 
Pour exemple j'emploi Lig, Col, FinLig, FinCol etc..
Un autre ptit truc... Dans tes noms de variables tu met une ou deux majuscules mais quand tu l'écrit tu ne met pas de majuscule, le nom va se mettre à jour automatiquement, si pas, c'est qu'il y a une erreur dans le nom.

Tranquillou · Answer

Excusez-moi pour la réponse tardive...
Toutes vos réponses m'ont permis de comprendre là où mon cerveau s'est limité.
En tout cas merci beaucoup car vos codes fonctionnent parfaitement et correspondent parfaitement à mes besoins.

Dernière petites questions beaucoup moins technique.
Quel ouvrage puis-je acheter pour maitriser "la chose" Excel en général et VBA. Quel est votre conseil ?

Copier ligne sans écraser les déjà existante

13 réponses

Discussions similaires