Forum |  HardWare.fr | News | Articles | PC | S'identifier | S'inscrire | Shop Recherche
1055 connectés 

  FORUM HardWare.fr
  Programmation
  VB/VBA/VBS

   Macro transformants les hyperliens text en hyperliens cliquables

 


 Mot :   Pseudo :  
 
Bas de page
Auteur Sujet :

Macro transformants les hyperliens text en hyperliens cliquables

n°1839880
delgoffe
Posté le 19-01-2009 à 11:11:23  profilanswer
 

Bonjour,
 
J'ai absolument besoin de votre aide pour transformer une macro
trouvée sur le net.
J'ai un classeur contenant des hyperliens et du texte standard.
Les hyperliens ne sont actuellement pas cliquables.
J'ai besoin que cette macro teste la feuille active pour y trouver les
hyperliens et qu'elle les rende tous cliquables s'ils ne le sont pas
déjà.
 
En gros, la page contiendrait
 
                  A                B                C                D
1     texte divers
2    http://www.monlien.fr           texte divers 2
3    texte divers3     http://www.monlien2.com
4    http://www.monlien4.fr         texte divers4    texte divers5
 
etc...
 
Actuellement, j'en suis arrivé à un script qui est composé comme
suit :
 
Sub AddHyperlinks()
 
    Dim rLastCell As Range
    Dim Cell As Range
 
    Set rLastCell = Worksheets("ActiveSheet" ).Range("A" & Cells.Rows.Count).End(xlUp)
 
    For Each Cell In Range("A1", rLastCell)
        If Not IsEmpty(Cell) Then _Cell.Hyperlinks.Add Cell, Cell.Text, TextToDisplay:="Click
to View"
    Next Cell
 
End Sub
 
Mon souci est qu'il n'y a pas de test conditionnel vérifiant que la
cellule contient bien un lien (qui commence toujours par http).
 
Je ne connais pas bien les macros mais je verrais un truc qui ferait
 
Sub AddHyperlinks() ' validation liens d'une colonne
 
    Dim rLastCell As Range
    Dim Cell As Range
 
    Set rLastCell = Worksheets("ActiveSheet" ).Range("A" & Cells.Rows.Count).End(xlUp)
 
    For Each Cell In Range("A1", rLastCell)
****        If (Cell) begins with "http" Then _   *****
            Cell.Hyperlinks.Add Cell, Cell.Text, TextToDisplay:="Click to View"
    Next Cell
 
End Sub
 
Pouvez-vous m'aider?
Evidemment, j'en ai besoin pour hier :)
 
Merci d'avance!

mood
Publicité
Posté le 19-01-2009 à 11:11:23  profilanswer
 

n°1839918
SuppotDeSa​Tante
Aka dje69r
Posté le 19-01-2009 à 13:05:55  profilanswer
 

Bonjour
 
Essaie cela :
 

Code :
  1. For Each Cell In Range("A1", rLastCell)
  2.         If Not IsEmpty(Cell) And InStr(1, Cell.Text, "http:" ) <> 0 Then _
  3.         Cell.Hyperlinks.Add Cell, Cell.Text, TextToDisplay:="Click to View"
  4. Next Cell


En lieu et place de ta boucle actuelle.
 
 
[edit] regarde dans l'aide, la fonction InStr() [/edit]
 
Cordialement


Message édité par SuppotDeSaTante le 19-01-2009 à 13:09:31

---------------
Soyez malin, louez entre voisins !
n°1839934
delgoffe
Posté le 19-01-2009 à 13:22:24  profilanswer
 

Apparemment, y a un truc qui bug
Il me dit : "run-time error '9'"
Subscript out of range.
Le debugger me met en surbrillance la ligne :
"Set rLastCell = Worksheets("ActiveSheet" ).Range("A" & Cells.Rows.Count).End(xlUp)"

n°1839938
SuppotDeSa​Tante
Aka dje69r
Posté le 19-01-2009 à 13:26:19  profilanswer
 

Euh... ta feuille se nomme ActiveSheet ? Je ne pense pas... ;)
 
Remplace ActiveSheet par le nom de ta feuille (onglet)  
Si ta feuille se nomme feuil1 : Set rLastCell = Worksheets("feuil1" ).Range("A" & Cells.Rows.Count).End(xlUp)
 
ou alors met un truc comme ca :  
Set rLastCell = ActiveSheet.Range("A" & Cells.Rows.Count).End(xlUp)  
 
Cordialement


Message édité par SuppotDeSaTante le 19-01-2009 à 13:27:18

---------------
Soyez malin, louez entre voisins !
n°1839949
delgoffe
Posté le 19-01-2009 à 13:46:53  profilanswer
 

Je n'ai plus d'erreur mais rien ne se passe.
La faute vient peut être d'une info que je n'ai pas donnée : les hyperliens sont générés par une formule.
Un exemple de contenu d'une cellule : =Modèle!$B$5&B$3&$B$9&B$4&Modèle!$D$5
 
Je vais chercher des modèles pour créer mes hyperliens.
Est-ce que ça peut avoir une incidence?
 
Merci

n°1839960
SuppotDeSa​Tante
Aka dje69r
Posté le 19-01-2009 à 13:55:59  profilanswer
 

  • Si je tape en A1 :

Toto

  • En A2

=B2

  • En B2

http://toto.fr  
 
Ce code fonctionne tres bien.

Code :
  1. Sub AddHyperlinks()
  2.     Dim rLastCell As Range
  3.     Dim Cell As Range
  4.     Set rLastCell = ActiveSheet.Range("A" & Cells.Rows.Count).End(xlUp)
  5.     For Each Cell In Range("A1", rLastCell)
  6.         If Not IsEmpty(Cell) And InStr(1, Cell.Text, "http:" ) <> 0 Then _
  7.         Cell.Hyperlinks.Add Cell, Cell.Text, ScreenTip:="Click " & Cell.Text, TextToDisplay:="Click " & Cell.Text
  8.     Next Cell
  9. End Sub


 
Envoie le fichier pour qu'on zieute, car les formules ne posent pas de souci puisqu'on regarde la propriete Text


Message édité par SuppotDeSaTante le 19-01-2009 à 13:58:57

---------------
Soyez malin, louez entre voisins !
n°1839969
delgoffe
Posté le 19-01-2009 à 14:02:12  profilanswer
 

J'ai trouvé en relisant ton exemple...
Je suis abruti... Je sais...ne le dites pas...
En fait, mes liens ne sont pas en colonne A
J'en ai en colonne C, en colonne D et en colonne E
Si j'adapte, ça jazz.
Le seul truc, c'est que c'est ch... d'adapter > nouvelle question : comment adapte le script pour qu'il fasse ce check dans toute la page active?
 
Merci encore

n°1839983
SuppotDeSa​Tante
Aka dje69r
Posté le 19-01-2009 à 14:14:35  profilanswer
 

:lol: je ne dis rien :x
 
Pour faire simple, tu regardes la derniere colonne, et la ligne la plus basse.
Ex :
Si la derniere colonne contenant des informations est la colonne Z
Et Si la derniere ligne contenant des informations est la 2543
 
Alors tu mets ca pour declarer rLastCell  
Set rLastCell = ActiveSheet.Range("Z2543" )


---------------
Soyez malin, louez entre voisins !
n°1839986
delgoffe
Posté le 19-01-2009 à 14:21:05  profilanswer
 

Nickel!
Me reste plus qu'à venir coller 2 boutons pour les générer et les retirer dans chaque feuille (20 feuilles)
Merci encore

n°1839994
SuppotDeSa​Tante
Aka dje69r
Posté le 19-01-2009 à 14:39:41  profilanswer
 

Sinon je t'ai fait ca :
 

Code :
  1. Sub AddHyperlinks()
  2.     Dim rLastCell As Range
  3.     Dim Cell As Range
  4.     Dim Coord As Range
  5.     Col = 0
  6.     Lig = 0
  7.    
  8. 'pour chaque colonne, il se met sur la derniere cellule, la 65536, et simule les touche Ctrl+FlecheHaut, ce qui donne la derniere ligne utilisée.
  9.     For x = 1 To 255
  10.         Set Coord = ActiveSheet.Range(Cells(65536, x), Cells(65536, x)).End(xlUp)
  11.         Lig1 = Coord.Row
  12.         If Lig1 > Lig Then
  13.             Lig = Lig1
  14.             Col = x
  15.         End If
  16.     Next x
  17.    
  18.     Set rLastCell = ActiveSheet.Range(Cells(Lig, Col), Cells(Lig, Col))
  19.     For Each Cell In Range("A1", rLastCell)
  20.         If Not IsEmpty(Cell) And InStr(1, Cell.Text, "http:" ) <> 0 Then _
  21.         Cell.Hyperlinks.Add Cell, Cell.Text, ScreenTip:="Click " & Cell.Text, TextToDisplay:="Click " & Cell.Text
  22.     Next Cell
  23. End Sub


 
Ca te permet de ne pas avoir a regarder la derniere ligne/colonne, il se demmerde tout seul pour trouver les coordonnées les plus basses, et les prend en reference.
 
Cordialement


Message édité par SuppotDeSaTante le 19-01-2009 à 14:43:07

---------------
Soyez malin, louez entre voisins !

Aller à :
Ajouter une réponse
  FORUM HardWare.fr
  Programmation
  VB/VBA/VBS

   Macro transformants les hyperliens text en hyperliens cliquables

 

Sujets relatifs
Text défilantBouton pour executer une macro dans une table access
Probleme création d'une macro [Macro Runner][Résolu][C] probleme avec une macro
Macro de création d'onglet dans excel[VBA] Mise à jour macro dans plusieurs fichiers...
Macro vba powerpointmacro pour 4 conditions
Récupérer la saisie sur userform dans la macro[RESOLU] Parsing de CSV avec Text::CSV_XC ou à l'arrache
Plus de sujets relatifs à : Macro transformants les hyperliens text en hyperliens cliquables


Copyright © 1997-2022 Hardware.fr SARL (Signaler un contenu illicite / Données personnelles) / Groupe LDLC / Shop HFR