ich habe eine große Pivottabelle in einer Spalte sind lauter URL`s.
Ist es möglich einen Hyperlink daraus zu machen?
Bisher stehen die URL`s nur als Text in der Spalte.
Habe keine Einstellung diesbezüglich gefunden.
Hat jemand eine Idee?
Gruß
Julia
Sub Makro1()
Dim rngFind As Range
Dim LCount As Long
With Sheets("Tabelle4") 'Deine Privottabelle
LCount = Application.WorksheetFunction.CountIf(.UsedRange, "*www.*")
For LCount = 1 To LCount
If rngFind Is Nothing Then
Set rngFind = .UsedRange.Find("*www.*", , xlFormulas, xlPart, xlByRows, xlNext, False, False)
Else
Set rngFind = .UsedRange.FindNext(rngFind)
End If
If Not rngFind Is Nothing Then rngFind.Hyperlinks.Add rngFind, rngFind.Text
Next LCount
End With
End Sub
Gruß Tino
Sub Makro1()
Dim rngFind As Range
Dim LCount As Long
With Sheets("Daten") 'Deine Privottabelle
LCount = Application.WorksheetFunction.CountIf(.UsedRange, "*www.*")
For LCount = 1 To LCount
If rngFind Is Nothing Then
Set rngFind = .UsedRange.Find("*http*", , xlFormulas, xlPart, xlByRows, xlNext, False, _
False)
Else
Set rngFind = .UsedRange.FindNext(rngFind)
End If
If Not rngFind Is Nothing Then rngFind.Hyperlinks.Add rngFind, rngFind.Text
Next LCount
End With
End Sub
Es kommt keine Fehlermeldung aber die URL`s sind immer noch nur als Text in der Pivot
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Count = 1 And InStr(Target, "http") > 0 Then
Cancel = True
ActiveWorkbook.FollowHyperlink Address:=Target.Text, NewWindow:=True
End If
End Sub
Am einfachsten, unten wo Du die Tabellenregiste sehen kannst, rechtsklick auf die Privottabelle und Code anzeigen auswählen, dort den Code rein kopieren.
Danach kannst Du mit doppelklick auf die Zelle den Hyperlink ausführen.
Gruß Tino
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Const Str_Die_Ersten As String = _
"http://www..." 'hier die ersten 70 Zeichen eintragen
If Target.Count = 1 And Target.Font.Underline = 2 Then
Cancel = True
ActiveWorkbook.FollowHyperlink Address:=Str_Die_Ersten & Target.Text, NewWindow:=True
End If
End Sub
kommt als Code in Modul1
Sub Makro1()
Dim rngFind As Range
Dim LCount As Long
With Sheets("Tabelle4") 'Deine Privottabelle
LCount = Application.WorksheetFunction.CountIf(.UsedRange, "http*")
For LCount = 1 To LCount
If rngFind Is Nothing Then
Set rngFind = .UsedRange.Find("http*", , xlFormulas, xlPart, xlByRows, xlNext, False, False)
Else
Set rngFind = .UsedRange.FindNext(rngFind)
End If
If Not rngFind Is Nothing Then
rngFind.Hyperlinks.Add rngFind, rngFind.Text, , , Right(rngFind.Text, Len(rngFind.Text) - 70)
End If
Next LCount
End With
End Sub
Gruß Tino