Feuille récapitulative

[xyvyos]

Bonjour,

J'ai créé un fichier regroupant des actions de maintenances à réaliser sur différents appareils. Chaque feuille aura le même format : en haut un tableau planning avec des croix qui montre à quel mois il faut réaliser la maintenance (en rouge si la date est passé, en vert si elle n'est pas encore passé), un deuxième tableau regroupant l'historique des interventions (lorsqu'on met la date, une croix s'affiche directement dans le tableau planning), et enfin un petit tableau commentaire.

Ce que j'aimerai faire c'est un petit tableau récapitulatif qui permettrait de voir directement si la case est rouge ou verte pour chaqu'unes des actions.
La première colonne serait le nom des actions et dans la seconde colonne on y verra les cases avec leur couleur correspondante.

Voila j'espère que je me suis fait comprendre.

Bonne journée

 

[st007]

Re : Feuille récapitulative

Bonjour,

Si j'ai compris, une option

 

[job75]

Re : Feuille récapitulative

Bonjour xyvyos, st007,

Voyez le fichier joint et cette macro dans le code de la feuille "0.RECAP" :

Private Sub Worksheet_Activate()
Dim lig&, ncol%, w As Worksheet
Application.ScreenUpdating = False
Rows("7:" & Rows.Count).Delete 'RAZ
lig = 6 '1ère ligne, à ne pas modifier
ncol = Cells(lig, Columns.Count).End(xlToLeft).Column
For Each w In Worksheets
  If w.Name <> Me.Name Then
    lig = lig + 1
    Cells(lig, 1) = w.Name
    With w.[A7].Resize(, ncol)
      .Copy Cells(lig, 1) 'pour copier les formats
      Cells(lig, 1).Resize(, ncol) = .Value 'valeurs
    End With
    Cells(lig, 1) = w.Name
  End If
Next
End Sub

Elle se déclenche quand on active la feuille.

A+

 

[xyvyos]

Re : Feuille récapitulative

Bonjour à vous,

Merci pour vos réponses. J'ai gardé celle de st007 car je préfere les formules aux macros, Même si je sais que parfois on a pas le choix ^^

J'ai une dernière petite requete. Est ce que vous savez comment on fait pour que lorsqu'on clique sur la dernière date, le curseur va directement sur la croix correspondante ?

Merci beaucoup

 

[st007]

Re : Feuille récapitulative

re,
çà sent un petit code vba évenementiel à placer dans la feuille , mais il est indispensable que tu développe

quel dernière date, où ---->la croix admettons, mais où quel onglet

 

[job75]

Re : Feuille récapitulative

Bonsoir,

Voyez ce que donne le double-clic dans la feuille "0.RECAP" (colonne A) et dans les autres feuilles (ligne 12).

Fichier (2).

Edit : dans la Worksheet_Activate j'avais écrit 2 fois Cells(lig, 1) = w.Name...

A+

 

[job75]

Re : Feuille récapitulative

Bonjour xyvyos, st007,

Dans la Worksheet_Activate on peut prendre des photos des cellules concernées :

Private Sub Worksheet_Activate()
Dim lig&, w As Worksheet, col As Variant
lig = 5 '1ère ligne, à adapter
Application.ScreenUpdating = False
Rows(lig & ":" & Rows.Count).Delete 'RAZ
Me.DrawingObjects.Delete 'supprime les objets
For Each w In Worksheets
  If w.Name <> Me.Name Then
    Cells(lig, 1) = w.Name
    col = Application.Match("X", w.Rows(7), 0)
    If IsNumeric(col) Then
      w.Cells(7, col).CopyPicture 'photo
      Me.Paste
      With Selection
        .Left = Cells(lig, 2).Left
        .Top = Cells(lig, 2).Top
        .ShapeRange.LockAspectRatio = msoFalse
        .Width = Cells(lig, 2).Width
        .Height = Cells(lig, 2).Height
      End With
      Cells(lig, 3) = CDate(w.Cells(6, col)) 'date
    End If
    lig = lig + 1
  End If
Next
ActiveCell.Activate
End Sub

Les photos prennent bien les couleurs affichées par les MFC.

Fichier (3).

A+

 

[job75]

Re : Feuille récapitulative

Re,

Variante (3 bis) pour la date :

Private Sub Worksheet_Activate()
Dim lig&, w As Worksheet, col As Variant
lig = 5 '1ère ligne, à adapter
Application.ScreenUpdating = False
Rows(lig & ":" & Rows.Count).Delete 'RAZ
Me.DrawingObjects.Delete 'supprime les objets
For Each w In Worksheets
  If w.Name <> Me.Name Then
    Cells(lig, 1) = w.Name
    col = Application.Match("X", w.Rows(7), 0)
    If IsNumeric(col) Then
      w.Cells(6, col).Copy Cells(lig, 2) 'date
      w.Cells(7, col).CopyPicture 'photo du "X"
      Me.Paste
      With Selection
        .Left = Cells(lig, 3).Left
        .Top = Cells(lig, 3).Top
        .ShapeRange.LockAspectRatio = msoFalse
        .Width = Cells(lig, 3).Width
        .Height = Cells(lig, 3).Height
      End With  
    End If
    lig = lig + 1
  End If
Next
ActiveCell.Activate
End Sub

A+

 

[job75]

Re : Feuille récapitulative

Re,

Dans cette version (4) on revient à la copie des MFC.

Les 2 cellules concernées sont toujours copiées en ligne 6, celle-ci est alors masquée :

Private Sub Worksheet_Activate()
Dim i&, w As Worksheet, col As Variant
Application.ScreenUpdating = False
Rows("6:" & Rows.Count).Delete 'RAZ
For i = Worksheets.Count To 1 Step -1
  Set w = Worksheets(i)
  If w.Name <> Me.Name Then
    Rows(6).Insert 'décale l'existant vers le bas
    Cells(6, 1) = w.Name
    col = Application.Match("X", w.Rows(7), 0)
    If IsNumeric(col) Then
      Rows(6).Insert
      w.Cells(6, col).Copy Cells(7, 2) 'date
      w.Cells(6, col).Resize(2).Copy Cells(6, 3)
      Cells(7, 3) = "X"
      Rows(6).Hidden = True 'la ligne est masquée
    End If
  End If
Next
End Sub

Bonne soirée.

 

[job75]

Re : Feuille récapitulative

Re,

Si l'on veut des titres au tableau de "0.RECAP" il vaut mieux les mettre en ligne 4 et masquer la ligne 5.

Fichier (4 bis).

A+

 

[job75]

Re : Feuille récapitulative

Re,

Avant d'aller dormir une dernière chose.

Avec des feuilles placées en désordre aucun problème si elles sont numérotées :

Private Sub Worksheet_Activate()
Dim w As Worksheet, maxi%, i%, col As Variant
Application.ScreenUpdating = False
Rows("6:" & Rows.Count).Delete 'RAZ
'---numéro maximum des feuilles---
For Each w In Worksheets
  If Val(w.Name) > maxi Then maxi = Val(w.Name)
Next w
'---copie des cellules "X"---
For i = maxi To 1 Step -1
  For Each w In Worksheets
    If Val(w.Name) = i Then
      Rows(6).Insert 'décale l'existant vers le bas
      Cells(6, 1) = w.Name
      col = Application.Match("X", w.Rows(7), 0)
      If IsNumeric(col) Then
        Rows(6).Insert
        w.Cells(6, col).Copy Cells(7, 2) 'date
        w.Cells(6, col).Resize(2).Copy Cells(6, 3)
        Cells(7, 3) = "X"
        Rows(6).Hidden = True 'la ligne est masquée
      End If
      Exit For
    End If
Next w, i
End Sub

Fichier (4 ter).

Bonne nuit.