Relier un prénom à un onglet en macro
Résolu
Valerie54001
Messages postés
135
Date d'inscription
Statut
Membre
Dernière intervention
-
Valerie54001 Messages postés 135 Date d'inscription Statut Membre Dernière intervention -
Valerie54001 Messages postés 135 Date d'inscription Statut Membre Dernière intervention -
Bonjour à tous,
Etant heureuse de l'aide donnée de façon récurrente, je viens vous solliciter une nouvelle fois avant les vacances.
L'idée de la macro que je souhaiterais, bien sur, si cela est possible, est tout simplement de déplacer chaque ligne dans un onglet approprié.
Sur chaque ligne, nous avons une date (colonne H), 2 prénoms (colonnes I et J) et un chiffre (colonne M).
La ligne 3 contient '' Pierre " et '' Marine" il faut la ranger sous les onglets ''Pierre" et "Marine" en A1.
La ligne 4 contient '' John " et '' Syvie" il faut la ranger sous les onglets ''Pierre" et "Marine" en A1.
etc.
Aussi il faut garder les couleurs.
https://www.cjoint.com/c/HGslyifHmNf
Qu'en dites vous ?
Etant heureuse de l'aide donnée de façon récurrente, je viens vous solliciter une nouvelle fois avant les vacances.
L'idée de la macro que je souhaiterais, bien sur, si cela est possible, est tout simplement de déplacer chaque ligne dans un onglet approprié.
Sur chaque ligne, nous avons une date (colonne H), 2 prénoms (colonnes I et J) et un chiffre (colonne M).
La ligne 3 contient '' Pierre " et '' Marine" il faut la ranger sous les onglets ''Pierre" et "Marine" en A1.
La ligne 4 contient '' John " et '' Syvie" il faut la ranger sous les onglets ''Pierre" et "Marine" en A1.
etc.
Aussi il faut garder les couleurs.
https://www.cjoint.com/c/HGslyifHmNf
Qu'en dites vous ?
3 réponses
-
Sinon, pour les doublons, essaie :
Sub test() Dim C As Range, Ligne As Long For i = 2 To Sheets.Count Sheets(i).[A:D].Clear Next i With Sheets("20172018") For Each C In .Range("H3", .Cells(.Rows.Count, 8).End(xlUp)) If C.Value <> "" Then With Sheets(C.Offset(, 1).Value) Ligne = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 If .[A1] = "" Then Ligne = 1 C.Resize(, 3).Copy .Cells(Ligne, 1) C.Resize(, 3).Copy .Cells(Ligne, 1).PasteSpecial xlPasteValues C.Offset(, 5).Copy .Cells(Ligne, 4) C.Offset(, 5).Copy .Cells(Ligne, 4).PasteSpecial xlPasteValues End With With Sheets(C.Offset(, 2).Value) Ligne = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 If .[A1] = "" Then Ligne = 1 C.Resize(, 3).Copy .Cells(Ligne, 1) C.Resize(, 3).Copy .Cells(Ligne, 1).PasteSpecial xlPasteValues C.Offset(, 5).Copy .Cells(Ligne, 4) C.Offset(, 5).Copy .Cells(Ligne, 4).PasteSpecial xlPasteValues End With End If Next C End With End Sub -
Bonjour,
"La ligne 4 contient '' John " et '' Syvie" il faut la ranger sous les onglets ''Pierre" et "Marine" en A1"
Tu es sure ?
Daniel -
Essaie :
Sub test()
Dim C As Range, Ligne As Long
With Sheets("20172018")
For Each C In .Range("H3", .Cells(.Rows.Count, 8).End(xlUp))
If C.Value <> "" Then
With Sheets(C.Offset(, 1).Value)
Ligne = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
If .[A1] = "" Then Ligne = 1
C.Resize(, 3).Copy .Cells(Ligne, 1)
C.Resize(, 3).Copy
.Cells(Ligne, 1).PasteSpecial xlPasteValues
C.Offset(, 5).Copy .Cells(Ligne, 4)
C.Offset(, 5).Copy
.Cells(Ligne, 4).PasteSpecial xlPasteValues
End With
With Sheets(C.Offset(, 2).Value)
Ligne = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
If .[A1] = "" Then Ligne = 1
C.Resize(, 3).Copy .Cells(Ligne, 1)
C.Resize(, 3).Copy
.Cells(Ligne, 1).PasteSpecial xlPasteValues
C.Offset(, 5).Copy .Cells(Ligne, 4)
C.Offset(, 5).Copy
.Cells(Ligne, 4).PasteSpecial xlPasteValues
End With
End If
Next C
End With
End Sub
Daniel-
Donc c'était bien possible !!
J'ai rajouté des nouveaux prénoms, je rencontre 2 soucis :
- Aprés avoir rajouté des prénoms j'ai le debuggeur qui s’arrête à <<With Sheets(C.Offset(, 1).Value)>>
- La macro s'effectue tellement bien qu'à chaque fois cela me fait des doublons lorsque je rajoute un prénom ( avec son onglet associé)
Peux-tu enlever les doublons, stp ? -
-
-
