Microsoft 365 rectangles (Shapes) qui affiche heure du dernier click

[gilles37]

Bonjour le forum

Sur une feuil je souhaiterai a chaque click du rectangle (shapes) apparaisse l'heure et date du dernier click en dessous du rectangle.
Le rectangle passe au rouge quand l'outil est emprunté et on reclique quand il est revenu( ca c'est bon)
J'ai x rectangles

Merci pour votre aide et bon week end.

 

[sylvanu]

Bonjour Gilles,
sans fichier test, on ne peut que supputer ...
Alors un essai en PJ. D'après ce que j'ai compris les rectangles ne sont pas utiles.
En PJ on clique sur une cellule de la colonne B.
Si l'outil est dispo il devient Emprunté et la cellule passe en rouge, sinon il devient dispo et la cellule est blanche. Avec :

Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo Fin: If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, [B2:B1000]) Is Nothing Then
        With Range(Target.Address)
            If .Interior.Color <> vbRed Then
                .Interior.Color = vbRed: .Value = "Emprunté": .Offset(0, 1) = Date
            Else
                .Interior.Color = xlNone: .Value = "Disponible": .Offset(0, 1) = ""
            End If
        End With
        [B1].Select
    End If
Fin:
End Sub

 

[job75]

Bonjour gilles37, sylvanu,

Avec des Shapes :

Sub Shape()
Dim s As Shape
Set s = ActiveSheet.Shapes(Application.Caller)
If s.Fill.ForeColor.RGB = vbRed Then
    s.Fill.ForeColor.RGB = vbGreen
    s.TopLeftCell.Offset(1) = ""
Else
    s.Fill.ForeColor.RGB = vbRed
    s.TopLeftCell.Offset(1) = Now
End If
End Sub

A+

 

[job75]

Il est important que chaque Shape soit positionnée et aussi dimensionnée sur sa cellule.

Si son nom contient l'adresse de la cellule :

Sub Shape()
Dim s As Shape
Set s = ActiveSheet.Shapes(Application.Caller)
If TypeName(Evaluate(Mid(s.Name, 2))) = "Range" Then
    With Evaluate(Mid(s.Name, 2))
        s.Top = .Top
        s.Left = .Left
        s.Width = .Width
        s.Height = .Height
    End With
End If
If s.Fill.ForeColor.RGB = vbRed Then
    s.Fill.ForeColor.RGB = vbGreen
    s.TopLeftCell.Offset(1) = ""
Else
    s.Fill.ForeColor.RGB = vbRed
    s.TopLeftCell.Offset(1) = Now
End If
End Sub

 

[gilles37]

Bonjour Sylvanu, Job75, le forum🖐
Merci pour vos retours.
Ca marche impeccable.
Beaucoup plus simple vs ce que j avais commencé a élaborer.
Vous etes au top
Merci

 

[gilles37]

Bonjour a tous
Je souhaite améliorer le fichier en ajoutant dans l'onglet "historiqu" le nom de la personne qui a emprunté l'outillage
J'ai essayé plusieurs façon sans succès
Auriez vous une idée? .
merci pour l'aide que vous pourrez apporter

 

[job75]

Bonjour gilles37,

En Feuil1 validez ou modifiez les noms Pierre et Jean et voyez la feuille "historiqu".

La macro dans le code de la feuille :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim nom$, dat$, i As Variant
nom = Target(1)
If Target.Row > 1 Then dat = Target(0, 1)
If Not IsDate(dat) Then Exit Sub
With Sheets("historiqu")
    i = Application.Match(CDbl(CDate(dat)), .Columns(3), 0)
    If IsNumeric(i) Then .Cells(i, 5) = nom
End With
End Sub

Edit : j'ai aussi modifié cette macro pour être sûr que les 2 dates/heures soient les mêmes :

Sub enregistre()
    With Sheets("historiqu")
        L = 1 + .Range("A65500").End(xlUp).Row
        .Cells(L, 1) = Application.Caller
        .Cells(L, 2) = Sheets("Feuil1").Shapes(Application.Caller).TextFrame2.TextRange.Text
        .Cells(L, 3) = Now
        Sheets("Feuil1").Shapes(Application.Caller).TopLeftCell.Offset(1) = .Cells(L, 3)
        .Cells(L, 4) = Sheets("Feuil1").Shapes(Application.Caller).Fill.ForeColor
    End With
End Sub

A+

 

[gilles37]

Bonjour Job75
je te remercie mais cela ne fonctionne que pour les 4 premiers.
J'ai une liste d'outillage et donc je faire de nombreux rectangles

 

[job75]

je te remercie mais cela ne fonctionne que pour les 4 premiers.

La faute à qui ? C'est quand même à vous de voir ça, un an après la création de ce fil.