Relier un prénom à un onglet en macro

Résolu/Fermé
Valerie54001 Messages postés 130 Date d'inscription mardi 22 novembre 2016 Statut Membre Dernière intervention 6 juin 2022 - 18 juil. 2018 à 13:30
Valerie54001 Messages postés 130 Date d'inscription mardi 22 novembre 2016 Statut Membre Dernière intervention 6 juin 2022 - 18 juil. 2018 à 21:19
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 ?

3 réponses

danielc0 Messages postés 695 Date d'inscription mardi 5 juin 2018 Statut Membre Dernière intervention 18 septembre 2022 56
18 juil. 2018 à 19:16
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
1
Valerie54001 Messages postés 130 Date d'inscription mardi 22 novembre 2016 Statut Membre Dernière intervention 6 juin 2022 1
18 juil. 2018 à 21:15
Super, le problème de doublon est résolu !!
0
danielc0 Messages postés 695 Date d'inscription mardi 5 juin 2018 Statut Membre Dernière intervention 18 septembre 2022 56
18 juil. 2018 à 16:24
Bonjour,

"La ligne 4 contient '' John " et '' Syvie" il faut la ranger sous les onglets ''Pierre" et "Marine" en A1"

Tu es sure ?

Daniel
0
Valerie54001 Messages postés 130 Date d'inscription mardi 22 novembre 2016 Statut Membre Dernière intervention 6 juin 2022 1
18 juil. 2018 à 17:28
Bonjour danielco,

Que je suis gourde parfois, j'ai copié collé sans corrigé.

Donc La ligne 4 contient '' John " et '' Sylvie" il faut la ranger sous les onglets ''John" et "Sylvie" en A.

Merci...
0
danielc0 Messages postés 695 Date d'inscription mardi 5 juin 2018 Statut Membre Dernière intervention 18 septembre 2022 56
18 juil. 2018 à 18:11
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
0
Valerie54001 Messages postés 130 Date d'inscription mardi 22 novembre 2016 Statut Membre Dernière intervention 6 juin 2022 1
Modifié le 18 juil. 2018 à 18:59
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 ?
0
danielc0 Messages postés 695 Date d'inscription mardi 5 juin 2018 Statut Membre Dernière intervention 18 septembre 2022 56
18 juil. 2018 à 19:12
Quel est le message d'erreur sur cette ligne ?
0
Valerie54001 Messages postés 130 Date d'inscription mardi 22 novembre 2016 Statut Membre Dernière intervention 6 juin 2022 1
18 juil. 2018 à 21:19
Corrigé sur le fichier test :)
0