Code vba excel 2007, déplacer une ligne

simomis Messages postés 1 Statut Membre -  
 Maurice -
bonjour tt le monde
j'ai besoin de votre précieuse aide sur excel
bref, j'ai un tableau de presque 1000 ligne
le problème que je n'arrive pas a compose le bon code vba qui me permettra de faire une recherche sur tous les cellules de le colonne D,ne i et si il trouve une cellule qui commence par exemple de 00150, coupe toute le ligne et la déplacer a la première ligne vide de la feuille 2
j'attends votre retour pcqe je commence a flipper
merci d'avence

3 réponses

  1. f894009 Messages postés 17417 Date d'inscription   Statut Membre Dernière intervention   1 717
     
    Bonjour,

    code pas des plus top, mais ca marche, ici code pour un bouton sur feuille 1

    Sub Bouton1_Cliquer()
    With Worksheets("feuil1")
    Recherche = "00150"
    'derniere cellule non vid ecolonne A
    derlig = .Range("A" & Rows.Count).End(xlUp).Row
    'mise en memoire plage de cellules
    Set Plage = .Range("D1:D" & derlig)
    'nombre de fois ce qui est recherche
    Nb = Application.CountIf(Plage, Recherche)
    'si au moins une fois
    If Nb > 0 Then
    lig = 1
    'boucle de recherche ligne
    For x = 1 To Nb
    lig = .Columns(4).Find(Recherche, .Cells(lig, 4), , xlWhole).Row
    'couper ligne
    .Rows(lig).EntireRow.Cut
    With Worksheets("feuil2")
    .Activate
    'premiere cellule vide colonne A
    Plvid = .Range("A" & Rows.Count).End(xlUp).Row + 1
    'selection cellule A de cette ligne
    .Range("A" & Plvid).Select
    'coloage
    ActiveSheet.Paste
    End With
    Next x
    End If
    End With
    End Sub
    0
  2. michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
     
    Pour avoir un début de réponse il faudrait ^tre clair....

    ...."le colonne D,ne i et si il ..."
    désolé, mais je n'ai pas compris

    Michel
    0
  3. Maurice
     
    Bonjour

    moi nom plus

    je perfere copy que cut

    Sub CopyLigne()
    Application.ScreenUpdating = False
    Lig = Feuil2.Cells(Rows.Count, 1).End(xlUp).Row + 1
    Nlig = Cells(Rows.Count, 1).End(xlUp).Row
       For L = Nlig To 2 Step -1
          If Cells(L, 2).Value = "00150" Then
             Rows(L).Copy
                Feuil2.Range("A" & Lig).PasteSpecial xlPasteValues
             Rows(L).Delete
             Lig = Lig + 1
          End If
       Next
    With Application
       .CutCopyMode = False
       .ScreenUpdating = True
    End With
    End Sub
    


    A+
    Maurice
    0