Liens hypertextes dynamiques et formes

Bonsoir,

J'ai inséré des plans dans un fichier excel où sont recensées des serrures de porte.

Dans la feuille base de données en colonne A, une forme rectangle transparente, amène (par macro) vers une autre "shape" de la feuille nommée "RDC". Le rectangle de destination change de couleur pour mieux être localisé.

Dans la feuille base de données, les informations en colonne A, peuvent occasionnellement monter ou descendre d'une ligne.

J'ai inséré un lien hypertexte manuellement sur chaque forme. Est-il possible de rendre ce lien hypertexte dynamique pour que le rectangle sélectionné soit toujours attaché à la cellule portant la même valeur (texte)?

Une autre question. Est-il possible de sélectionner une forme (rectangle par exemple) selon le texte qui y est inséré à l'intérieur?

Merci pour l'aide que vous pourrez m'apporter.

Pour la première question, j'ai utilisé testé l'enregistreur de macro. Il y a certainement mieux mais cela fonctionne.

Exemple :

Sub Macro2()
    On Error GoTo SUITE
    Sheets("Base de données").Select
    Cells.Find(What:="6C", After:=ActiveCell, LookIn:=xlValues, LookAt _
    :=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase _
    :=False, SearchFormat:=False).Activate
    SUITE:
    Exit Sub
End Sub

Bonjour,

Une première proposition à étudier.

Cdlt.

Merci Jean-Eric, c'est génial. Une seule macro au lieu de 300 et quelques macros individuelles. Cela me fait gagner beaucoup de temps.

Serait-il possible d'adapter la macro ci-après pour que le principe fonctionne dans les deux sens :

La macro prendrait alors en compte, la valeur de la forme l'ayant lancée, pour trouver la forme de destination. Cela me permettrait également de n'utiliser qu'une seule macro.

Exemple :

Sub A006F()
    Range("A43").Select 'Forme d'où est lancée la macro[/color]
    Dim rStart As Range
    Dim shp As Shape
    Dim sFind As String
    Dim sTemp As String
    sFind = ActiveCell.Value 'Valeur de la forme lançant la macro
    Set rStart = ActiveCell
    Sheets(4).Select
    For Each shp In ActiveSheet.Shapes
        sTemp = shp.TextFrame.Characters.Text
        If InStr(LCase(sTemp), LCase(sFind)) <> 0 Then
            shp.Select
            With Selection.ShapeRange.Fill
                .Visible = msoTrue
                .ForeColor.RGB = RGB(255, 0, 0)
                .Transparency = 0.5099999905
                .Solid
            End With
            Call Unselectshapes
        End If
    Next
End Sub

J'ai avancé dans ma recherche, la macro ci-après fonctionne.

Pourriez-vous me préciser s'il est possible d'exécuter cette macro sur plusieurs feuilles (sauf la première) sans qu'elles soient sélectionnées afin de ne pas compromettre les macros évènementielles :

Sub TestA()
    Dim i As Integer
    Dim rStart As Range
    Dim shp As Shape
    Dim sFind As String
    Dim sTemp As String
    Dim st As String
    sFind = ActiveSheet.Shapes(Application.Caller).TextFrame.Characters.Text
    Sheets(4).Select 'Permettre l'exploitation de cette macro sur tout le classeur sauf la première feuille
    For Each shp In ActiveSheet.Shapes
        If shp.Name <> "dudu" Then 'L'image de fond (plan absent de mon fichier exemple) est exclue pour ne pas générer d'erreur. 
            sTemp = shp.TextFrame.Characters.Text
            If InStr(LCase(sTemp), LCase(sFind)) <> 0 Then
                shp.Select
                With Selection.ShapeRange.Fill
                    .Visible = msoTrue
                    .ForeColor.RGB = RGB(255, 0, 0)
                    .Transparency = 0.5099999905
                    .Solid
                End With
                Call Unselectshapes
            End If
        End If
    Next
End Sub

Je n'ai pas trouvé de la solution qui aplliquerait la macro ci-desus à l'ensemble des feuilles du classeur.

Pour ceux que cela intéresse, j'ai utilisé la macro ci-après pour que la forme que je sélectionne prenne la valeur (le texte pas le nom de la forme) de la cellule active de mon choix.

Sub ValeurCelluleActive()
    Dim ActiveShape As Shape
    Dim UserSelection As Variant
    Set UserSelection = ActiveWindow.Selection
    On Error GoTo SUITE
    Set ActiveShape = ActiveSheet.Shapes(UserSelection.Name)
    ActiveShape.TextFrame.Characters.Text = ActiveCell.Offset(0, 0).Value
    SUITE:
    Exit Sub
End Sub