Microsoft 365 VBA pour faire une boucle

Emile63

XLDnaute Junior
Bonjour à tous,

Je cherche a faire une boucle par rapport à une zone que j'aurais préalablement sélectionnée à la souris, qu'a chaque cellule soit mis l'hyperlien jusqu'a la fin de la sélection.
au coup par coup, mon code fonctionne (à peu près) par contre je peine avec la sélection "MaZone" à la souris...
La macro consiste à mettre en hyperlien le contenu de la cellule (nom et chemin de fichiers)
Je vous remercie d'avance pour votre support, et vous souhaite une belle journée.
------------------------------------
Sub Clipboard_Hyperlien()
Dim maZone As Range
Set Clipboard = New MSForms.DataObject
Clipboard.GetFromClipboard
strContents = Clipboard.GetText

With ActiveSheet
For Each maZone In Selection

If ActiveCell.Value <> "" Then
Application.ActiveWindow.ActiveCell.Copy
If strContents <> "" Then
strContents = Replace(strContents, Chr(34), "")
If Selection.Hyperlinks.Count > 0 Then Selection.Hyperlinks.Delete
ActiveCell.Hyperlinks.Add Anchor:=ActiveCell, Address:=strContents

With Selection
.HorizontalAlignment = xlLeft
.Font.Size = 12
.Font.TintAndShade = 0
.Font.Underline = xlUnderlineStyleSingle
' .Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
End With
Else
MsgBox "Aucun fichier dans le clipboard", vbInformation + vbOKCancel, "Opération annulée."
End If

Else
End If

Next

End Sub
 
Solution
Bonjour AtTheOne,

J'ai itrouvé une autre solution (en cherchant sur le site 🙂 )

LH = Right(LH, Len(LH) - InStrRev(LH, Application.PathSeparator))
fileExt = Split(LH, ".")
LH = fileExt(0)
C.Value = LH
Et du coup ma boucle fonctionne parfaitement.

Encore merci pour ton aide.

AtTheOne

XLDnaute Impliqué
Supporter XLD
Bonjour à tous, bonjour @Emile63

Je n'ai pas trop compris ce que tu faisais avec le presse papier ...
Mais s'il s'agit de créer des liens HT avec le contenu des cellules d'une sélection ce code fait l'affaire :
Enrichi (BBcode):
Sub Crée_Hyperlien()

     Dim Ma_Zone As Range, C As Range, LH As String
     Set Ma_Zone = Selection
     
     With Ma_Zone
          For Each C In .Cells
               With C
                    If .Value <> "" Then
                         LH = Replace(.Value, Chr(34), "")                                               'Supprimer les " du texte
                         If .Hyperlinks.Count > 0 Then C.Hyperlinks.Delete                               'Supprimer le LH de la cellule s'il existe
                         .Hyperlinks.Add Anchor:=C, Address:=LH, ScreenTip:="Clic pour suivre le lien"   'Créer le Lien HT
                     End If
               End With
          Next
          'Mise en forme sur toute la sélection
          .HorizontalAlignment = xlLeft
          .Font.Size = 12
          '...
     End With
     
End Sub

Voir le fichier joint

Amicalement
Alain
 

Pièces jointes

  • Cell_Liens HT.xlsm
    17.4 KB · Affichages: 4

Emile63

XLDnaute Junior
Bonjour AtTheOne, merci pour ton aide.

ça fonctionne très bien!
Une fois que le lien , je voudrais ajouter à la boucle, de changer le contenu de la cellule active.
Avec la formule suivante je supprime tout le chemin du fichier ainsi que son extension pour ne garder que le nom du fichier, le problème c'est que je n'arrive pas à adapter cette formule au code VBA.

ActiveCell.FormulaR1C1 = _
"=TRIM(MID(RC[-1],SEARCH(""µ"",SUBSTITUTE(RC[-1],""\"",""µ"",LEN(RC[-1])-LEN(SUBSTITUTE(RC[-1],""\"",""""))))+1,LEN(RC[-1])-(SEARCH(""µ"",SUBSTITUTE(RC[-1],""\"",""µ"",LEN(RC[-1])-LEN(SUBSTITUTE(RC[-1],""\"","""")))))-(LEN(RC[-1])-FIND(""."",RC[-1])+1)))"

Un coup de main serait le bienvenu. 🙄
Merci,
Emile
 

Emile63

XLDnaute Junior
Bonjour AtTheOne,

J'ai itrouvé une autre solution (en cherchant sur le site 🙂 )

LH = Right(LH, Len(LH) - InStrRev(LH, Application.PathSeparator))
fileExt = Split(LH, ".")
LH = fileExt(0)
C.Value = LH
Et du coup ma boucle fonctionne parfaitement.

Encore merci pour ton aide.
 

AtTheOne

XLDnaute Impliqué
Supporter XLD
Bonjour
J'ai itrouvé une autre solution (en cherchant sur le site 🙂 )

J'étais en train d'écrire :
Enrichi (BBcode):
Sub Crée_Hyperlien()

     Dim Ma_Zone As Range, C As Range, LH As String, Nom
     Set Ma_Zone = Selection
   
     With Ma_Zone
          For Each C In .Cells
               With C
                    If .Value <> "" Then
                         LH = Replace(.Value, Chr(34), "")                                              'Supprimer les " du texte
                         Nom = Split(LH, "\")                                                           'Extraire le nom+extension (dernier élément du tableau)
                         Nom = Split(Nom(UBound(Nom)), ".")(0)                                          'Extraire le nom sans extension (premier élément du tableau)
                         If .Hyperlinks.Count > 0 Then C.Hyperlinks.Delete                               'Supprimer le LH de la cellule s'il existe
                         .Hyperlinks.Add Anchor:=C, Address:=LH, ScreenTip:=LH, TextToDisplay:=Nom      'Créer le Lien HT
                     End If
               End With
          Next
          'Mise en forme sur toute la sélection
          .HorizontalAlignment = xlLeft
          .Font.Size = 12
          '...
     End With
   
End Sub
Comme quoi on arrive à peu près à la même solution ...

A bientôt
Modif : Avec le fichier, c'est mieux ...
Alain
 

Pièces jointes

  • Cell_Liens HT.xlsm
    18.6 KB · Affichages: 2

Discussions similaires

Statistiques des forums

Discussions
311 733
Messages
2 082 019
Membres
101 872
dernier inscrit
Colin T