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

Valoche54000 à dit:

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

Cliquez pour agrandir...

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

job75 à dit:

Bonjour Valoche54000,

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

Code:

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+

Cliquez pour agrandir...

job75 à dit:

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+

Cliquez pour agrandir...