AW: Hyperlink auslesen
19.04.2018 13:11:16
UweD
Hallo
z.B. so
Option Explicit
Sub Hyper_tausch()
Dim TB As Worksheet, Zelle, Suchen As String
Dim TMP1 As Integer, TMP2 As Integer, TMP3 As String
Dim Alt As String, Neu As String, Datei As String
Dim Err As Boolean
'Ist =WENN(M23="";"";HYPERLINK(FindFile("Z:\Pfad\"&M23&"*.pdf");"A"))
'Soll =HYPERLINK("Z:\Pfad\Dateiname.pdf")
Set TB = Sheets("Tabelle1")
Suchen = "HYPERLINK(FindFile"
For Each Zelle In TB.Cells.SpecialCells(xlCellTypeFormulas)
'Zelle.Select 'nur für Test
Alt = Zelle.FormulaLocal
TMP1 = InStr(Alt, Suchen)
If TMP1 > 0 Then ' ist das eine Formel in Alter Form
Neu = "=" & Mid(Alt, InStr(Alt, Suchen))
Neu = Replace(Neu, "FindFile(", "")
TMP1 = InStr(Neu, """&")
TMP2 = InStr(Neu, """*")
'Zelladresse ermitteln
TMP3 = Mid(Neu, TMP1 + 2, TMP2 - TMP1 - 3)
'Dateiname aus Zelle
Datei = Range(TMP3)
If Datei <> "" Then
'Endung wieder anhängen
TMP2 = InStr(Neu, ");")
Neu = Left(Neu, TMP1 - 1) & Datei & Mid(Neu, TMP1 + Len(TMP3) + 5)
'Rest hinten abschneiden
TMP2 = InStr(Neu, ";""")
Neu = Left(Neu, TMP2 - 1)
'Formel zurückschreiben
Zelle.Formula = Neu
Else
'kein Dateiname in Zelle, dann rot färben
Zelle.Interior.Color = RGB(255, 0, 0)
Err = True
End If
End If
Next
If Err Then MsgBox "Fehler in den roten Zellen"
End Sub
Ist kein Dateiname in der referenzierten Zelle wird nichts verändert; Zelle wir rot