relier un prénom à un onglet en macro Résolu/Fermé

Question

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 ?

danielc0 · Answer

Bonjour,

"La ligne 4 contient '' John " et '' Syvie" il faut la ranger sous les onglets ''Pierre" et "Marine" en A1"

Tu es sure ?

Daniel

danielc0 · Answer

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 WithEnd Sub

Daniel

danielc0 · Answer

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

Relier un prénom à un onglet en macro

3 réponses

Discussions similaires