copier/coller lignes sous condition colonne vers autre feuille

**juniorglobal08** · 21/05/2009, 12h47

Bonjour a tous,

Une nouvelle question de copy/paste pour laquelle je bloque.
Voici mon proble : je oudris arriver a copier des lignes entiere de ma feuill "Base" vers d'autres onglet en fonction du nom inscris dan sla colonne B.

Si le meme nom appart plusiseurs fois, il faut que toutes les lignes de la colonne B qui comporte se nom soit copier dans une nouvelle feuille.

Si un nom n'apparait q'une seule fois alors sa ligne seulement sera copier dans une nouvelle feuille.

voila mon code

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Sub test()
Application.ScreenUpdating = True
Dim Plage As Range, x As Integer, j As Integer, y As Integer, k As Integer, l As Integer, i As Integer, z As Byte
x = 3
y = 0
k = 0
l = 0
z = 1
 
'enleve filtre
'ROws("2:2").Select
'Selection.AUtoFilter
 
'select et tri premiere colonne
'Worksheets("Base").Activate
'Range("B3").Select
'Range("A1:N382").Sort Keyl:=Range("B3"), orderl:=xlAscending, Header:= xlGuess, Ordercustom:=1, Matchcase:=False, orientation:=xlTOpTOBottom, _ Dataoptionl:=xlSortNormal

Je commence par fare un tri sur la colonne qui m'interesse B

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
'Boucle select et copy libellé identique worksheets("Base").Activate
Set Plagel = Worksheets("Base").Range("B3:B" & Range("B3").End(xlDown).Row) 'Set Plage2 = worksheets("Base").Range("B3:B" & Range("B3").End(xlDown).ROw)
 
    For j = Plagel.Cells.Count To 3 Step -1
'Plagel.Cells(j).Value = uCase(Plagel.Cells(j).value) 'Plagel.Cells(j - 1).value = ucase(Plagel.cells(j - 1).Value)
    For i = Plagel.Cells.Count To 3 Step -1
        If Plagel.Cells(j).Value = Plagel.Cells(j - 1).Value Then
            i = j + 2
            Plagel.Cells(i).Select
            nbr = Selection.Count
            k = i - nbr
            Range("A" & k, "M" & i).Select
            Selection.Copy
            Sheets.Add Range("A3").Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
 
            Else
            Exit For
        End If
    Next
 
'Else
 
      If Plagel.Cells(j).Value <> Plagel.Cells(j - 1).Value Then
            Plagel.Cells(j).EntireRow.Select
            Plagel.Cells(j).EntireRow.Copy
            'crée un onglet et insere ligne copier
            Sheets("Base").Select
            Sheets.Add
            Range("A3").Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
          End If
       Next
 
'renomme onglet
 
'Sheets("Feui11").select
'Sheets("Feuill").Name= Range("B3").value
 
End Sub

puis je fais 2 boucles qui doivent me permettre de selectionner et copier les lignes qui m'interressent.

le probleme est qu je ne selectionne pas touts les doublons (ligne qui ont le meme nom dans la colonne B)

voila j'espere avoir été clair.

Je reviendré avec des precisions si necessaire, merci pour votre aide.

col A col B col C col D col E
num ag nom ag resp ag nb ag gogh
nom ag resp ag nb ag gogh
1 mesure qlmjhlg 2316 oifjp^qe
2 efface qlmjhlg 2317 oifjp^qe
3 niche qlmjhlg 2318 oifjp^qe
4 loupe qlmjhlg 2319 oifjp^qe
5 souris qlmjhlg 2320 oifjp^qe
6 souris qlmjhlg 2321 oifjp^qe
7 souris qlmjhlg 2322 oifjp^qe
8 souris qlmjhlg 2323 oifjp^qe

voici un extrait du tableau pour mieux comprendre, en clair il faut que j'arrive a copier la ligne un dans une feuille, puis la ligne 2, 3,4. Puis les lignes 5678 dans une autre et insi desuite.

**Minick** · 21/05/2009, 14h36

Salut,

Pas sur d'avoir compris.

Tu trouveras dans ce code une facon de faire.
J'ai considere en feuille 1 ton tableau de base.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
Option Explicit
 
Sub Dispatcher()
    Dim CptLig As Integer
    Dim Feuille As Worksheet
 
    For CptLig = 3 To Feuil1.Range("B65536").End(xlUp).Row
        Set Feuille = Nothing
 
        If Not FeuilleExiste(Feuil1.Range("B" & CptLig).Value) Then
            Set Feuille = Sheets.Add(After:=Worksheets(Worksheets.Count))
            Feuille.Name = Feuil1.Range("B" & CptLig).Value
            Feuil1.Rows("1:2").Copy Destination:=Feuille.Rows("1:2")
        End If
        If Feuille Is Nothing Then Set Feuille = Sheets(Feuil1.Range("B" & CptLig).Value)
        Feuil1.Rows(CptLig).Copy Destination:=Feuille.Range("A" & Feuille.Range("A65536").End(xlUp).Row + 1)
    Next CptLig
    Feuil1.Activate
End Sub
 
 
Function FeuilleExiste(Nom As String) As Boolean
    Dim Feuille As Worksheet
 
    FeuilleExiste = False
    For Each Feuille In Worksheets
        If LCase(Feuille.Name) = LCase(Nom) Then
            FeuilleExiste = True
            Exit For
        End If
    Next Feuille
End Function

A noter que le tri n'est pas necessaire de cette facon.

++
Minick

**juniorglobal08** · 21/05/2009, 15h25

Salut minick et merci bcp pour ce code je pense que cela m'aidera pour la suite une fois que j'aurais terminé la premiere partie de la macro.

D'apres ce que je coprnd ton code permet d'jaouter des feuilles a lasuite de la premiere en leur donnat un nm choisiet d'apres la liste de la colonne B.

Ce qu'il me faut dans un premier temps c de pouvoir copier les lignes de la feuille "Base" dans d'autres feuilles que je crée audur et a mesure comme dans ton exemple.

mon probleme pour l'instant et que je n'arrive ps a copier les lignes correspondante.

je redonne mon exemple en piece jointe.

NB je dois commencr a coller les lignes à partir de la troisieme ligne car j'ai un entete.

**Minick** · 21/05/2009, 16h07

Re,

Ma macro fait exactement ce que tu veux mais effectivement
il y a un souci a cause de la fusion (maudites fusions... )des cellules d'entetes.

En adaptant un peu le code tout rentre dans l'ordre, j'ai simplement ajouter la
condition que si la ligne de destination n'est pas au minimun la 3eme je force a 3.
J'ai mi des '**** a cote des changement, tu verras que le code change tres peu

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
Option Explicit
 
Sub Dispatcher()
    Dim CptLig As Integer, LigDst As Integer '***** declaration d'un variable upplementaire
    Dim Feuille As Worksheet
 
    For CptLig = 3 To Feuil1.Range("B65536").End(xlUp).Row
        Set Feuille = Nothing
 
        If Not FeuilleExiste(Feuil1.Range("B" & CptLig).Value) Then
            Set Feuille = Sheets.Add(After:=Worksheets(Worksheets.Count))
            Feuille.Name = Feuil1.Range("B" & CptLig).Value
            Feuil1.Rows("1:2").Copy Destination:=Feuille.Rows("1:2")
        End If
        If Feuille Is Nothing Then Set Feuille = Sheets(Feuil1.Range("B" & CptLig).Value)
 
        LigDst = Feuille.Range("A65536").End(xlUp).Row + 1 '**** recherche de la derniere ligne
        If LigDst < 3 Then LigDst = 3 '**** on verifie si on est inferieur a 3 dans ce cas on met 3
        Feuil1.Rows(CptLig).Copy Destination:=Feuille.Range("A" & LigDst) '**** integration de la variable dans l'instruction
    Next CptLig
    Feuil1.Activate
End Sub
 
 
Function FeuilleExiste(Nom As String) As Boolean
    Dim Feuille As Worksheet
 
    FeuilleExiste = False
    For Each Feuille In Worksheets
        If LCase(Feuille.Name) = LCase(Nom) Then
            FeuilleExiste = True
            Exit For
        End If
    Next Feuille
End Function

++
Minick

**juniorglobal08** · 21/05/2009, 16h53

waou!!

ca marche meme super bien.
mais j'avoue que je comprend la moitié du code seulement.

la deuxieme boucle elle sert à verifier que toutes les cellules ont bien été recopiée, et qu'il n'ya pas de doublon dansle sfeuileles crées?

Je ne comprend pas comment et ou tu stocke les lignes identiques?

merci pour ton aide

**Minick** · 21/05/2009, 17h29

re,

On ne stocke rien:

on lit la cellule B3
on appelle la fonction (FeuilleExiste) pour savoir si une feuille du nom de B3 existe
Si elle n'existe pas on la cree, la nomme du nom de B3 et on ajoute les 2 lignes d'entete
On recherche la derniere ligne utilisee de la feuille destination
si on est inferieur a la ligne 3 on force a 3
on copie la ligne 3 dans la feuille de destination a la position recherche precedemment
Et on continue pour chaque Cellule de la colonne B (B4, B5, Bn....)

Comme dit sur le post precedemment, pas besoin de trier la liste avant, car a chaque cellule (bx) on regarde si la feuille correspondante existe

Voila j'espere que c'est un peu plus clair.

++
Minick

copier/coller lignes sous condition colonne vers autre feuille

Macros et VBA Excel

Discussions similaires

Partager

Partager