copie de liens hypertexte

[xavoul]

Bonjour
Dans une colonne A, j'ai une liste de codes de pays (FR pour France, etc.), chaque code de pays comprenant un lien hypertexte différent.
J'ai une colonne B avec le nom des pays correspondant aux codes, mais le nom de pays (plus intelligible) ne comprennent aucun lien hypertexte.
Je voudrais donc coller les liens hypertexte de chaque case la colonne A vers chaque case correspondante de la colonne B sans modifier le texte des cases de la colonne B.
Bien sûr, je peux le faire à la main... mais c'est long, et ce n'est pas drôle...
Vous avez une idée de macro ?
merci à tous

 

[job75]

Bonsoir xavoul, bienvenue sur XLD,

Placez cette macro dans le code de la feuille (clic droit sur l'onglet et Visualiser le code) :

Sub CopierLiens()
Dim c As Range
On Error Resume Next
For Each c In [A:A].SpecialCells(xlCellTypeConstants, 2)
    With c.Hyperlinks(1)
        c(1, 2).Hyperlinks.Add c(1, 2), .Address, TextToDisplay:=c(1, 2).Text
        c(1, 2).Hyperlinks.Add c(1, 2), .Address, .SubAddress, TextToDisplay:=c(1, 2).Text
    End With
Next
End Sub

Puis exécutez-la (Alt+F8).

A+

 

[mapomme]

Bonjour xavoul,

Sélectionner les cellules de la colonne B puis lancer la macro suivante:

Sub Macro1()
Dim xcell As Range
   For Each xcell In Selection
      If xcell <> "" Then
         If xcell.Offset(, -1).Hyperlinks.Count > 0 Then
            xcell.Hyperlinks.Add Anchor:=xcell, _
            Address:=xcell.Offset(, -1).Hyperlinks(1).Address, _
            TextToDisplay:=xcell.Value
         End If
      End If
   Next xcell
End Sub[/B]

Edit : pas réactualisé ; Bonsoir job75

 

[job75]

Re, salut mapomme, heureux de te croiser,

Beaucoup plus simple et rapide :

Sub CopierLiens2()
Dim mem
With ActiveSheet.UsedRange
    If .Parent.FilterMode Then .Parent.ShowAllData 'si la feuille est filtrée
    mem = .Columns(2)
    .Columns(1).Copy .Columns(2)
    .Columns(2) = mem
End With
End Sub

A+

 

[job75]

Re,

Testé avec 10 000 liens :

- macro du post #2 (ou 3) => 20 secondes

- macro du post #4 => 0,5 seconde.

A+

 

[xavoul]

Bonsoir xavoul, bienvenue sur XLD,

Placez cette macro dans le code de la feuille (clic droit sur l'onglet et Visualiser le code) :

Sub CopierLiens()
Dim c As Range
On Error Resume Next
For Each c In [A:A].SpecialCells(xlCellTypeConstants, 2)
    With c.Hyperlinks(1)
        c(1, 2).Hyperlinks.Add c(1, 2), .Address, TextToDisplay:=c(1, 2).Text
        c(1, 2).Hyperlinks.Add c(1, 2), .Address, .SubAddress, TextToDisplay:=c(1, 2).Text
    End With
Next
End Sub

Puis exécutez-la (Alt+F8).

A+

Bonjour Job75, Bonjou Mapomme,

Merci infiniment pour ces propositions qui fonctionnent à merveille !