Tableaux, signets et hyperliens

[Arsene12]

Bonjour,

j'ai un tableau qui contient un intitulé dans une cellule.
Je voudrai créer une macro qui :

1 - crée un signet au tableau à partir de cet intitulé.
2 - crée un lien hypertexte qui renvoie vers le tableau (signet) lorsque cet intitulé se retrouve dans l'une des pages du document.

Auriez-vous une solution simple à m'apporter ? Merci d'avance.

[carden752]

Bonjour,

Une solution simple, pas facile.
Voyons quand même une méthode possible :
Commençons par le début, quel est l'intitulé, un mot, un groupe de mot, une phrase?

1. Se positionner sur la cellule
2. Récupérer le mot clé dans une variable
3. Se positionner au début du tableau
4. Ajuster l'intitulé pour en faire un mot valide pour un signet (Replace peut-être utile)
5. Créer le signet

Pour créer un signet

Code :

1
2
 
selection.bookmarks.add nomdusignet

Voila pour la partie 1.

La partie 2, on verrra après mais en voici le principe

1. Créer un lien hypertexte
2. Le copier
3. Remplacement de toutes les occurences de l'intitulé par le contenu du presse papier
4. Supprimer le premier lien hypertexte

Je te laisse chercher un peu, si tu as des questions, n'hésite pas

[Arsene12]

Bonsoir,

Merci beaucoup pour ces renseignements. Je pense que je vais pouvoir y arriver mais je butte sur un dernier obstacle essentiel. Cela concerne le nommage du signet. Je voudrais lui donner le nom du fichier ouvert (qui respecte la règle liée au nom des signets). Si je tape ceci :

Code :

1
2
3
4
5
    With ActiveDocument.Bookmarks
        .Add Range:=Selection.Range, Name:="FileName"
        .DefaultSorting = wdSortByName
        .ShowHidden = False
    End With

C'est le nom "filename" qui s'enregistre.

[carden752]

Bonjour,

Envoyé par Arsene12

Merci beaucoup pour ces renseignements. Je pense que je vais pouvoir y arriver mais je butte sur un dernier obstacle essentiel. Cela concerne le nommage du signet. Je voudrais lui donner le nom du fichier ouvert (qui respecte la règle liée au nom des signets). Si je tape ceci :
With ActiveDocument.Bookmarks
.Add Range:=Selection.Range, Name:="FileName"
.DefaultSorting = wdSortByName
.ShowHidden = False
End With
C'est le nom "filename" qui s'enregistre.

C'est normal car tu lui donnes la chaîne de caractère Filename comme nom.
Pour donner le nom du document, tu peux utiliser la propriété FullName

Code :

1
2
3
4
5
With ActiveDocument.Bookmarks
        .Add Range:=Selection.Range, Name:=Activedocument.FullName
        .DefaultSorting = wdSortByName
        .ShowHidden = False
End With

[Arsene12]

Bonsoir, merci beaucoup, je pense n'avoir plus que 2 étapes à franchir avant de pouvoir fournir le code complet.

Je suis sur une page blanche avec mon tableau en bas de page et je voudrais récupérer le contenu de la 1ère cellule du tableau (un simple nom) pour le copier en haut du document.

J'essaie ce code :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
 
Sub CopyContentCell()'
 
ActiveDocument.Tables(1).Cell(1, 1).Select
 
Selection.Copy
 
Selection.HomeKey Unit:=wdStory ' place le cursaur en debut du document
 
Selection.Paste
 
End Sub

mais j'obtiens la copie de la cellule complète (un nouveau tableau) et non le texte seul.

[Arsene12]

Bonjour,
Je viens de trouver un nouveau code qui marche presque:

Code :

1
2
3
4
5
6
7
 
 
Set myrange = ActiveDocument.Tables(1).Cell(1, 1).Range 'sélectionne le contenu de la cellule
 
Selection.HomeKey Unit:=wdStory ' place le cursaur en debut du document
 
Selection.TypeText Text:=myrange ' colle le texte contenu dans la cellule

Le problème qui apparait, c'est que le curseur vient se positionner en desous du texte copié en affichant un gros point.

MONTEXTE

• <--

J'aimerai donc que le curseur se positionne juste à la fin de MONTEXTE sans gros point

MONTEXTE <--

[carden752]

Bonjour,

Surement une marque de fin de cellule, je te propose une alternative, ne pas reprendre le dernier caractère puis rajouter ou pas une marque de paragraphe.

Code :

1
2
3
4
5
6
7
8
9
10
11
12
Sub tableau()
'déclaration
Dim myrange As Range
Set myrange = ActiveDocument.Tables(1).Cell(1, 1).Range 'sélectionne le contenu de la cellule
'Enlever le dernier caractère
myrange.End = myrange.End - 1
'Rajouter la marque de paragraphe
myrange.Text = myrange.Text & Chr(13)
Selection.HomeKey Unit:=wdStory ' place le cursaur en debut du document
 
Selection.TypeText Text:=myrange
End Sub

[Arsene12]

Bonjour,
merci beaucoup, je suis proche de la résolution du problème maintenant. J'ai testé le code et la ligne avec .end = .end - 2 (et non - 1) donne le résultat que j'attendais. Par contre, je ne suis pas arrivé à comprendre à quoi servait la marque de paragraphe. Ce que j'ai fait ensuite, c'est que j'ai rajouté des marqueurs de type "***" avant de copier le contenu de la cellule en début de page.

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
Sub tableau()
'déclaration
Dim myrange As Range
Set myrange = ActiveDocument.Tables(1).Cell(1, 1).Range 'sélectionne le contenu de la cellule
myrange.End = myrange.End - 2 'Enleve les deux derniers caractères
   'Rajoute des marqueurs de type "***"
With myrange 
    .InsertBefore "***"
    .InsertAfter "***"
End With
Selection.HomeKey Unit:=wdStory ' place le cursaur en debut du document
Selection.TypeText Text:=myrange ' Colle le contenu de la cellule
End Sub

Je cherche maintenant une solution pour que ces marqueurs disparaissent au niveau de la cellule du tableau une fois l'opération réalisée.

[carden752]

Bonjour,
la marque de paragraphe permettait d'insérer ce bloc dans un paragraphe distinct et ne pas le coller en début de document sans retour à la ligne après.
Ceci dit, je suis content que cela ait pu t'aider.
Tu peux essayer en l'enlevant, tu verras que tu auras une ligne en moins.

[Arsene12]

Bonsoir,
Je m'excuse, j'ai fait une erreur dans mon message précédent. Il s'agit bien de myrange.End = myrange.End - 1 et non - 2 pour avoir le curseur positionné en fin de mot en haut de la page.
La correction étant faite, j'ai continué mon programme en voulant réinitialiser la cellule dans laquelle j'avais reformater le texte pour lui inclure des marqueurs "***".
J'ai utilisé une fonction qui permet de copier la cellule dans le presse papier avant de faire la modification, et à la fin je l'ai coller sur son emplacement initial. Voici le code :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
 
Sub Tableau()
Dim myrange As Range 'déclaration
Set myrange = ActiveDocument.Tables(1).Cell(1, 1).Range 'sélectionne le contenu de la cellule
    ActiveDocument.Tables(1).Rows(1).Cells(1).Select
    Selection.Copy ' copie la cellule dans le presse-papier
myrange.End = myrange.End - 1 'Enleve le dernier caractère (la marque de fin de cellule)
  With myrange             'Rajoute des marqueurs de type "***"
    .InsertBefore "***"
    .InsertAfter "***"
End With
Selection.HomeKey Unit:=wdStory ' place le cursaur en debut du document
Selection.TypeText Text:=myrange ' Colle le contenu de la cellule modifiée
ActiveDocument.Tables(1).Rows(1).Cells(1).Range _
    .PasteAsNestedTable ' colle la cellule initiale copiée dans le presse-papier
End Sub

Ça marche mais voilà que le même problème apparait : j'ai un retour chariot qui vient s'ajouter et créer une nouvelle ligne au bas de la cellule en l'agrandissant. Comment faire pour éviter cet autre retour chariot?

[Arsene12]

J'ai trouvé la formule pour recopier une formule à l'identique. Je vous donne le code précédent modifié :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Sub Tableau()
Dim myrange As Range 'déclaration
Set myrange = ActiveDocument.Tables(1).Cell(1, 1).Range 'sélectionne le contenu de la cellule
    ActiveDocument.Tables(1).Rows(1).Cells(1).Select
    Selection.Copy ' copie la cellule dans le presse-papier
myrange.End = myrange.End - 1 'enleve le dernier caractère (la marque de fin de cellule)
  With myrange             'ajoute des marqueurs de type "***"
    .InsertBefore "***"
    .InsertAfter "***"
End With
Selection.HomeKey Unit:=wdStory ' place le cursaur en debut du document
Selection.TypeText Text:=myrange ' colle le contenu de la cellule modifiée
With ActiveDocument.Tables(1).Cell(1, 1).Range ' sélectionne la position ou va se faire la copie
.Paste ' colle la cellule copiée précédemment dans le presse-papier
End With    
End Sub

Mais j'ai trouvé une autre manière aussi simple de réaliser ce que je voulais faire :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
Sub Tableau()
'déclaration
Dim myrange As Range
Dim M As String
M = "***"
Set myrange = ActiveDocument.Tables(1).Cell(1, 1).Range 'sélectionne le contenu de la cellule
myrange.End = myrange.End - 1 'enlève le dernier caractère (la marque de fin de cellule)
   'ajoute des marqueurs de type "***"   
   Selection.HomeKey Unit:=wdStory ' place le cursaur en debut du document
Selection.TypeText Text:=M ' ajoute le 1er marqueur
Selection.TypeText Text:=myrange ' colle le contenu de la cellule
Selection.TypeText Text:=M ' ajoute le 2ème marqueur   
   End Sub

[Arsene12]

Je pense que je vais me servir des 2 méthodes. La première va me servir à formater le texte à l'intérieur de la cellule afin qu'il puisse être utiliser pour le nom du signet que je vais attribuer au tableau. Ensuite je vais pouvoir récupérer le texte de la cellule initiale après l'avoir collée pour le placer en début de document et en faire un hyperlien qui renvoie vers le tableau.

La question que je me pose maintenant c'est comment éliminer de ma cellule tous les caractères qui ne sont ni des chiffres ni des lettres? Existe-t-il une solution simple pour cela?

[Arsene12]

Bonjour,
J'ai trouvé la formule qui me permet d'éliminer les chiffres :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
Sub Eliminatinolettre()
Selection.MoveUp Unit:=wdScreen, Count:=1
Selection.Find.ClearFormatting
While (A <> 1)
Selection.Find.ClearFormatting
With Selection.Find
.Text = "^#"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.Delete
If Not (Selection.Find.Found) Then
A = 1
Else
End If
Wend
End Sub

et celle qui me permet d'éliminer les lettres :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
Sub Eliminatinolettre()
Selection.MoveUp Unit:=wdScreen, Count:=1
Selection.Find.ClearFormatting
While (A <> 1)
Selection.Find.ClearFormatting
With Selection.Find
.Text = "^$"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.Delete
If Not (Selection.Find.Found) Then
A = 1
Else
End If
Wend
End Sub

Je ne sais pas comment traduire le code suivant:

si Ma Sélection = Chiffre alors (ne rien faire)
si Ma Sélection = Lettre alors (ne rien faire)
si Ma Sélection = "*" alors A=1
sinon Selection.Delete