Conserver lien hypertexte

Bonjour à tous,

Je travaille à créer une base de donnée sur Excel à partir d'infos issues d'internet. J'arrive au résultat escompté, sauf pour un point :

il figure parmi les données un lien hypertexte. Lorsque je convertis le texte pour créer deux colonnes, ce lien hypertexte disparaît. J'ai essayé de m'inspirer des précédents posts, mais je ne parviens pas à utiliser VBA comme il faut.

Je vous remercie par avance pour votre aide.

Je vous joins le fichier Excel concerné avec en feuille 3 les données brutes et en feuille 1 le résultat escompté.

Voici le code en question :

Sub separateur()

'

' separateur Macro

'

'

ActiveCell.Columns("A:A").EntireColumn.Select

Selection.TextToColumns Destination:=ActiveCell, DataType:=xlDelimited, _

TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _

Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _

:=":", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True

ActiveCell.Columns("A:A").EntireColumn.Select

Selection.Delete Shift:=xlToLeft

End Sub

Bonjour

L'instruction pour copier un lien hypertexte situé en A8 avec son contenu en B8 est

With Range("A8").Hyperlinks(1)
    Range("B8").Hyperlinks.Add Range("B8"), .Address, , , .TextToDisplay
End With

Mais, je suis incapable de l'adapter dans ton Code

Cordialement

Bonsoir

A essayer

Une solution (pas sur que cela soit la plus simple)

Remplaces ta macro Sub separateur() par celle-ci

Sub Conversion()
Dim HLink As Hyperlink
Dim Adr As String
Dim J As Long

  Application.ScreenUpdating = False
  With Sheets("Feuil3")
    For Each HLink In .Hyperlinks
      Adr = Adr & HLink.Range.Address & ","
    Next HLink

    For J = 1 To .Range("A" & Rows.Count).End(xlUp).Row
      If .Range("A" & J) <> "" Then
        If InStr(Adr, .Range("A" & J).Address & ",") = 0 Then
          .Range("A" & J).TextToColumns Destination:=.Range("A" & J), DataType:=xlDelimited, _
                                        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
                                        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:=":", _
                                        FieldInfo:=Array(Array(1, xlSkipColumn), Array(2, 1)), TrailingMinusNumbers:=True
        End If
      End If
    Next J
  End With
End Sub

Bonsoir

Une version plus simple

Sub Conversion()
Dim J As Long

  Application.ScreenUpdating = False
  With Sheets("Feuil3")

    For J = 1 To .Range("A" & Rows.Count).End(xlUp).Row
      If .Range("A" & J) <> "" Then
        If .Range("A" & J).Hyperlinks.Count = 0 Then          ' Ce n'est pas un lien
          .Range("A" & J).TextToColumns Destination:=.Range("A" & J), DataType:=xlDelimited, _
                                        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
                                        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:=":", _
                                        FieldInfo:=Array(Array(1, xlSkipColumn), Array(2, 1)), TrailingMinusNumbers:=True
        End If
      End If
    Next J
  End With
End Sub

Bonjour,

Je lis seulement vos réponses aujourd'hui. J'ai entre temps modifié le code en compilant une suite de macros simples... Je vais essayer vos idées qui vont être plus simple que ce que j'ai fait. Et ça me permet de comprendre de mieux en mieux VBA !

Voici donc le code bidouillé, avec le résultat en PJ (feuille 1 pour le résultat et feuille 2 pour le point de départ).

Merci encore pour votre aide !

Matthieu C.

Sub Conversion()

'Sub suppr rna

' Suppr rna1 Macro

' Macro enregistrée le 08/02/2012 par CREDIT COOPERATIF

'

'

'

For i = ActiveSheet.UsedRange.Rows.Count To 1 Step -1

If Cells(i, 1) Like "*Identification*" Then Rows(i).Delete

Next

'end sub

'Sub lignesvides()

With ActiveSheet.UsedRange

derLi = .Row + .Rows.Count - 1

End With

Application.ScreenUpdating = False

For r = derLi To 1 Step -1

If Application.CountA(Rows(r)) = 0 Then Rows(r).Delete

Next r

'end Sub

'Sub Conversionprov()

' Conversion Macro

Dim Ligne As Long

Dim Compteur As Long

Compteur = 1

Ligne = Compteur + 1

With Sheets("Feuil1")

.Rows(Compteur).Insert

While .Cells(Ligne, 1) <> ""

.Range("A" & Ligne & ":A" & Ligne + 3).Copy

.Cells(Compteur, 1).PasteSpecial Transpose:=True

Compteur = Compteur + 1

Ligne = Ligne + 4

Wend

End With

Range("A" & Compteur & ":A" & Ligne).ClearContents

'End Sub

'Sub Separateur()

' Séparateur2 Macro

' Macro enregistrée le 08/02/2012 par CREDIT COOPERATIF

'

'

Columns("A:A").Select

Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _

TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _

Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _

:=":", FieldInfo:=Array(Array(1, 9), Array(2, 1)), TrailingMinusNumbers:=True

Columns("B:B").Select

Selection.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _

TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _

Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _

:=":", FieldInfo:=Array(Array(1, 9), Array(2, 1)), TrailingMinusNumbers:=True

Columns("C:C").Select

Selection.TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, _

TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _

Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _

:=":", FieldInfo:=Array(Array(1, 9), Array(2, 1)), TrailingMinusNumbers:=True

' miseenpage Macro

' Macro enregistrée le 08/02/2012 par CREDIT COOPERATIF

'

'

Rows("1:1").Select

Selection.Insert Shift:=xlDown

Range("A1").Select

ActiveCell.FormulaR1C1 = "Association"

Range("B1").Select

ActiveCell.FormulaR1C1 = "Sieren"

Range("C1").Select

ActiveCell.FormulaR1C1 = "Clôture compte"

Range("D1").Select

Columns("C:C").ColumnWidth = 14.57

Range("D1").Select

ActiveCell.FormulaR1C1 = "Lien vers Compte"

Cells.Select

Cells.EntireRow.AutoFit

Cells.EntireColumn.AutoFit

End Sub

Bonjour

En compilant les macros

Merci !