Leerzeichen in Hyperlink-Pfad
08.02.2018 10:29:11
Thomas
ich stehe mal wieder vor einem Problem.
Mit dem folgenden Code korrigiere ich Hyperlinks. Funktioniert auch tadellos.
Das doppelte "Archiv" wird aus dem Pfad entfernt.
Option Explicit
Sub hyperlink_setzen()
Dim xAnzLinks As Long, x1 As Long, Zielspalte As Long
Dim ReplaceALT As String
Dim ReplaceNEU As String
Dim tmpC1 As String, tmpC2 As String
For Zielspalte = 84 To 165 '2 = Spalte "B"
xAnzLinks = ActiveSheet.Hyperlinks.Count
ReplaceALT = "\Matrix\Region\Archiv\Archiv\"
ReplaceNEU = "\Matrix\Region\Archiv\"
For x1 = 1 To xAnzLinks
tmpC1 = ActiveSheet.Hyperlinks(x1).Address
If InStr(1, tmpC1, ReplaceALT) 0 Then 'nur ausgwählte Links ändern
'MsgBox tmpC1
If ActiveSheet.Hyperlinks(x1).Parent.Column = Zielspalte Then
tmpC1 = Replace(tmpC1, ReplaceALT, ReplaceNEU)
'MsgBox tmpC1
' HYPERLINK korrigieren
ActiveSheet.Hyperlinks(x1).Address = tmpC1
tmpC2 = "zeile " & ActiveSheet.Hyperlinks(x1).Parent.Row
tmpC2 = tmpC2 & "Spalte " & ActiveSheet.Hyperlinks(x1).Parent.Column
tmpC2 = tmpC2 & " am " & Date & " um " & Time
ActiveSheet.Hyperlinks(x1).ScreenTip = tmpC2
End If
End If
Next x1
Zielspalte = Zielspalte + 1
Next Zielspalte
End Sub
Option Explicit
Sub hyperlink_setzen()
Dim xAnzLinks As Long, x1 As Long, Zielspalte As Long
Dim ReplaceALT As String
Dim ReplaceNEU As String
Dim tmpC1 As String, tmpC2 As String
For Zielspalte = 84 To 165 '2 = Spalte "B"
xAnzLinks = ActiveSheet.Hyperlinks.Count
ReplaceALT = "\Matrix\Region West\Archiv\"
ReplaceNEU = "\Matrix\Region West\Dokumente\Archiv\"
For x1 = 1 To xAnzLinks
tmpC1 = ActiveSheet.Hyperlinks(x1).Address
If InStr(1, tmpC1, ReplaceALT) 0 Then 'nur ausgwählte Links ändern
'MsgBox tmpC1
If ActiveSheet.Hyperlinks(x1).Parent.Column = Zielspalte Then
tmpC1 = Replace(tmpC1, ReplaceALT, ReplaceNEU)
'MsgBox tmpC1
' HYPERLINK korrigieren
ActiveSheet.Hyperlinks(x1).Address = tmpC1
tmpC2 = "zeile " & ActiveSheet.Hyperlinks(x1).Parent.Row
tmpC2 = tmpC2 & "Spalte " & ActiveSheet.Hyperlinks(x1).Parent.Column
tmpC2 = tmpC2 & " am " & Date & " um " & Time
ActiveSheet.Hyperlinks(x1).ScreenTip = tmpC2
End If
End If
Next x1
Zielspalte = Zielspalte + 1
Next Zielspalte
End Sub
Hat jemand einen Lösungsvorschlag?
Viele Grüße und besten Dank,
Thomas