XL 2013 Macro pour transférer des données d'un feuille à l'autre avec cellules colorées

[Valoche54000]

Bonjour la communauté,

Sur le fichier téléversé, avec la macro '' répartition '', j'essaie de transférer les données de la feuille principale à d'autres onglets.
les colonnes H,I,J,M se déverseront dans les 20 onglets portant le nom des équipes automatiquement dés lors de la mise à jour de l'onglet ''20172018''
Exemple Ligne 3: dans les onglets '' ACAjaccio'' et '' Niort '' nous aurons H3,I3,J3, et O3.
Jusque là, j'y arrive. par contre je ne comprends pas pourquoi les cellules colorées ne le sont plus une fois transférées dans les différents onglets.

Sub répartition()
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

Quelqu'un à une idée ?

 

[job75]

Bonjour Valoche54000,

Avec le fichier du post#7 de job75, il faudrait modifier le code car le code se déclenche quand on active une feuille en laissant d'éventuels commentaires dans les colonnes G ou H ou autres > la colonne F : ils disparaissent.

Le code devrait interagir avec les 6 premiéres colonnes de A à F et ne pas supprimer le contenu des autres colonnes >F

Ce code mémorise et restitue d'éventuels commentaires en colonne G :

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim d As Object, c As Range
With Sheets("20172018") 'nom à adapter
    If Sh.Name = .Name Then Exit Sub
    Application.ScreenUpdating = False
    On Error Resume Next
    '---mémorisation des commentaires en colonne G---
    Set d = CreateObject("Scripting.dictionary")
    For Each c In Sh.[G:G].SpecialCells(xlCellTypeConstants)
        d(c(1, -5).Value) = c
    Next
    Sh.Cells.Delete 'RAZ
    Intersect(.UsedRange.EntireRow, .[A:AI]).Copy Sh.[A1] 'copie tout le UsedRange
End With
Sh.UsedRange = Sh.UsedRange.Value 'supprime les formules
Sh.[A:G,N:AI].Delete 'pour alléger, reste 6 colonnes
If Sh.UsedRange.Row > 1 Then Sh.Rows("1:" & Sh.UsedRange.Row - 1).Delete 'facultatif
With Intersect(Sh.UsedRange.EntireRow, Sh.[G:G]) '7ème colonne auxiliaire
    .FormulaR1C1 = "=1/AND(RC2<>""" & Sh.Name & """,RC3<>""" & Sh.Name & """)"
    .Value = .Value 'supprime les formules
    .EntireRow.Sort .Cells, xlDescending, Header:=xlNo 'tri pour accélérer
    .SpecialCells(xlCellTypeConstants, 1).EntireRow.Delete
    .ClearContents
End With
Sh.Columns("A:C").AutoFit 'ajustement largeur
Sh.Columns("D:E").Hidden = True 'masquage facultatif
Sh.Columns("F").ColumnWidth = 4
Application.Goto Sh.[A1], True 'cadrage
AllerRetour Sh
'---restitution des commentaires en colonne G---
For Each c In Sh.[A:A].SpecialCells(xlCellTypeConstants)
    If d.exists(c.Value) Then c(1, 7) = d(c.Value)
Next
Sh.[G:G].Font.Color = vbRed 'police rouge
End Sub

Chaque commentaire est repéré et restitué par la date en colonne A (normalement il n'y a pas plus d'une rencontre par jour).

Fichier (4).

A+

 

[Valoche54000]

Bonjour Valoche54000,

Ce code mémorise et restitue d'éventuels commentaires en colonne G :

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim d As Object, c As Range
With Sheets("20172018") 'nom à adapter
    If Sh.Name = .Name Then Exit Sub
    Application.ScreenUpdating = False
    On Error Resume Next
    '---mémorisation des commentaires en colonne G---
    Set d = CreateObject("Scripting.dictionary")
    For Each c In Sh.[G:G].SpecialCells(xlCellTypeConstants)
        d(c(1, -5).Value) = c
    Next
    Sh.Cells.Delete 'RAZ
    Intersect(.UsedRange.EntireRow, .[A:AI]).Copy Sh.[A1] 'copie tout le UsedRange
End With
Sh.UsedRange = Sh.UsedRange.Value 'supprime les formules
Sh.[A:G,N:AI].Delete 'pour alléger, reste 6 colonnes
If Sh.UsedRange.Row > 1 Then Sh.Rows("1:" & Sh.UsedRange.Row - 1).Delete 'facultatif
With Intersect(Sh.UsedRange.EntireRow, Sh.[G:G]) '7ème colonne auxiliaire
    .FormulaR1C1 = "=1/AND(RC2<>""" & Sh.Name & """,RC3<>""" & Sh.Name & """)"
    .Value = .Value 'supprime les formules
    .EntireRow.Sort .Cells, xlDescending, Header:=xlNo 'tri pour accélérer
    .SpecialCells(xlCellTypeConstants, 1).EntireRow.Delete
    .ClearContents
End With
Sh.Columns("A:C").AutoFit 'ajustement largeur
Sh.Columns("D:E").Hidden = True 'masquage facultatif
Sh.Columns("F").ColumnWidth = 4
Application.Goto Sh.[A1], True 'cadrage
AllerRetour Sh
'---restitution des commentaires en colonne G---
For Each c In Sh.[A:A].SpecialCells(xlCellTypeConstants)
    If d.exists(c.Value) Then c(1, 7) = d(c.Value)
Next
Sh.[G:G].Font.Color = vbRed 'police rouge
End Sub

Chaque commentaire est repéré et restitué par la date en colonne A (normalement il n'y a pas plus d'une rencontre par jour).

Fichier (4).

A+

Bien vu job75.

Serais-tu capable de me libérer les colonnes de G à l'infini?

 

[job75]

Re,

Cela ne servirait à rien.

Dans les feuilles les commentaires sont forcément liés aux rencontres : si on supprime les rencontres dans la feuille "20172018" il faut que les commentaires disparaissent.

On pourrait les avoir dans plusieurs colonnes mais je n'en vois pas l'intérêt.

A+

 

[Valoche54000]

Re,

Cela ne servirait à rien.

Dans les feuilles les commentaires sont forcément liés aux rencontres : si on supprime les rencontres dans la feuille "20172018" il faut que les commentaires disparaissent.

On pourrait les avoir dans plusieurs colonnes mais je n'en vois pas l'intérêt.

A+

Donc je suis bloquée pour l'instant.
Je vais crééer un nouveau poste la suite de mon projet espérant que cela donnes des idées.