Hyperlink aus Zellinhalt

Sub HL_Ü_automatisch() Dim zeile As Range Dim Hyper As Hyperlink Dim strPath As Byte For Spalte = 1 To 15 If Cells(2, Spalte) = "Gemarkung :" Then Spalte = Spalte + 2 Cells(2, Spalte).Select 'Zelle wird ausgewählt Worksheets(1).Hyperlinks.Add Anchor:=Selection, Address:=Cells(2, Spalte) & "_ohne_FF- _ Liste\" 'Hyperlink wird eingefügt For Each Hyper In Cells(2, Spalte).Hyperlinks If strPath > 10 Then Hyper.Address = Replace(Hyper.Address, strPath, "\0" & strPath) Else Hyper.Address = Replace(Hyper.Address, strPath, "\00" & strPath) End If Hyper.Address = Replace(Hyper.Address, " Fl. ", "") Hyper.Address = Replace(Hyper.Address, " Flur ", "") Hyper.Address = Replace(Hyper.Address, ",", "") Hyper.Address = Replace(Hyper.Address, "(", "") Hyper.Address = Replace(Hyper.Address, ")", "") Hyper.Address = Replace(Hyper.Address, " ", "_") Next Hyper Cells(2, Spalte).Activate With Selection.Font .Name = "Arial" .Size = 12 .Underline = xlUnderlineStyleSingle .ColorIndex = 5 .TintAndShade = 0 .ThemeFont = xlThemeFontNone End With Selection.Font.Bold = True End If Next MsgBox "Hyperlink gesetzt !!!" End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit 'Teterow (1763), Flur 20--->Teterow_1763\020 'Teterow (1763), Fl. 2--->Teterow_1763\002 'Dann gibt es noch die Variante: 'Altkalen_(1674), Flur 1--->Altkalen_1674\001_ohne FF-Liste Sub HL_Ü_automatisch() 'Dim zeile As Range Dim Spalte As Long 'Dim Hyper As Hyperlink Dim varPath As Variant Dim strLink As String, strLinkLeft As String Dim iPos As Integer, iPos2 As Integer Dim bolOhneFF As Boolean For Spalte = 1 To 15 If Cells(2, Spalte) = "Gemarkung :" Then Spalte = Spalte + 2 Cells(2, Spalte).Select 'Zelle wird ausgewählt strLink = Cells(2, Spalte).Text '"(" im Link suchen iPos = InStr(1, strLink, "(") If iPos > 0 Then If Mid(strLink, iPos - 1, 1) = " " Then bolOhneFF = False strLink = VBA.Replace(strLink, " (", "_") ElseIf Mid(strLink, iPos - 1, 1) = "_" Then bolOhneFF = True strLink = VBA.Replace(strLink, "(", "") Else MsgBox "Links vom Zeichen ""("" im Zell-Text" & vbLf & strLink & vbLf _ & "steht kein "" "" oder ""_""" GoTo nextSpalte End If '")" im Link suchen iPos = InStr(iPos, strLink, ")") If iPos > 0 Then strLink = VBA.Replace(strLink, ")", "\") Else MsgBox "Zeichen "")"" im Zelltext" & vbLf & strLink & vbLf & _ "rechts von Zahl nicht gefunden!" GoTo nextSpalte End If strLinkLeft = Left(strLink, iPos) 'Suchen nach der 1. Ziffer nach ")" iPos2 = iPos + 1 Do If IsNumeric(Mid(strLink, iPos2, 1)) Then Exit Do End If iPos2 = iPos2 + 1 Loop iPos = iPos2 'Position der Ziffer merken 'Suchen bis Zeichen nicht mehr nummerisch Do If Not IsNumeric(Mid(strLink, iPos2, 1)) Then varPath = Mid(strLink, iPos, iPos2 - iPos) strLink = strLinkLeft & Format(Val(varPath), "000") _ & IIf(bolOhneFF, "_ohne FF-Liste", "") & Mid(strLink, iPos2) Exit Do ElseIf iPos2 = Len(strLink) Then varPath = Mid(strLink, iPos, iPos2 - iPos + 1) strLink = strLinkLeft & Format(Val(varPath), "000") _ & IIf(bolOhneFF, "_ohne FF-Liste", "") Exit Do End If iPos2 = iPos2 + 1 Loop MsgBox "Hyperlinkadresse: " & vbLf & strLink 'Testzeile ' Cells(3, Spalte) = strLink 'Testzeile Worksheets(1).Hyperlinks.Add Anchor:=Selection, Address:=strLink 'Hyperlink wird _ eingefügt With Cells(2, Spalte).Font .Name = "Arial" .Size = 12 .Underline = xlUnderlineStyleSingle .ColorIndex = 5 .TintAndShade = 0 .ThemeFont = xlThemeFontNone .Bold = True End With Else MsgBox "Zeichen ""("" im Link" & vbLf & strLink & vbLf & "nicht gefunden!" End If End If nextSpalte: Next Spalte MsgBox "Hyperlink gesetzt !!!" End Sub

Option Explicit 'Teterow (1763), Flur 20--->Teterow_1763\020 'Teterow (1763), Fl. 2--->Teterow_1763\002 'Dann gibt es noch die Variante: 'Altkalen_(1674), Flur 1--->Altkalen_1674\001_ohne FF-Liste Sub HL_Ü_automatisch() 'Dim zeile As Range Dim Spalte As Long 'Dim Hyper As Hyperlink Dim varPath As Variant Dim strLink As String, strLinkLeft As String, strLinkOhneFF As String, strUngeprueft As _ String Dim iPos As Integer, iPos2 As Integer For Spalte = 1 To 15 If Cells(2, Spalte) = "Gemarkung :" Then Spalte = Spalte + 2 Cells(2, Spalte).Select 'Zelle wird ausgewählt strLink = Cells(2, Spalte).Text '"(" im Link suchen iPos = InStr(1, strLink, "(") If iPos > 0 Then If Mid(strLink, iPos - 1, 1) = " " Then strLink = VBA.Replace(strLink, " (", "_") ElseIf Mid(strLink, iPos - 1, 1) = "_" Then strLink = VBA.Replace(strLink, "(", "") Else MsgBox "Links vom Zeichen ""("" im Zell-Text" & vbLf & strLink & vbLf _ & "steht kein "" "" oder ""_""" GoTo nextSpalte End If '")" im Link suchen iPos = InStr(iPos, strLink, ")") If iPos > 0 Then strLink = VBA.Replace(strLink, ")", "\") Else MsgBox "Zeichen "")"" im Zelltext" & vbLf & strLink & vbLf & _ "rechts von Zahl nicht gefunden!" GoTo nextSpalte End If strLinkLeft = Left(strLink, iPos) 'Suchen nach der 1. Ziffer nach ")" iPos2 = iPos + 1 Do If IsNumeric(Mid(strLink, iPos2, 1)) Then Exit Do End If iPos2 = iPos2 + 1 Loop iPos = iPos2 'Position der Ziffer merken 'Suchen bis Zeichen nicht mehr nummerisch Do If Not IsNumeric(Mid(strLink, iPos2, 1)) Then varPath = Mid(strLink, iPos, iPos2 - iPos) strLinkOhneFF = strLinkLeft & Format(Val(varPath), "000") _ & "_ohne FF-Liste" & Mid(strLink, iPos2) strLink = strLinkLeft & Format(Val(varPath), "000") _ & Mid(strLink, iPos2) Exit Do ElseIf iPos2 = Len(strLink) Then varPath = Mid(strLink, iPos, iPos2 - iPos + 1) strLinkOhneFF = strLinkLeft & Format(Val(varPath), "000") _ & "_ohne FF-Liste" strLink = strLinkLeft & Format(Val(varPath), "000") Exit Do End If iPos2 = iPos2 + 1 Loop 'Ordner "ungeprüft" - mir ist unklar, wo dieser Ordner liegt!!! strUngeprueft = strLinkLeft & Format(varPath, "000") & "\ungeprüft\" 'Dateiname anhängen_ strUngeprueft = strUngeprueft & Mid(strLink, InStrRev(strLink, "\") + 1) If Dir(strUngeprueft) "" Then strLink = strLinkOhneFF End If MsgBox "Hyperlinkadresse: " & vbLf & strLink 'Testzeile Worksheets(1).Hyperlinks.Add Anchor:=Selection, Address:=strLink 'Hyperlink _ wird eingefügt With Cells(2, Spalte).Font .Name = "Arial" .Size = 12 .Underline = xlUnderlineStyleSingle .ColorIndex = 5 .TintAndShade = 0 .ThemeFont = xlThemeFontNone .Bold = True End With Else MsgBox "Zeichen ""("" im Link" & vbLf & strLink & vbLf & "nicht gefunden!" End If End If nextSpalte: Next Spalte MsgBox "Hyperlink gesetzt !!!" End Sub

Option Explicit 'Excel_Datei: G:\FF-Listen\Gemarkungen\1763-020.xls --> Zelltext:Teterow (1763), Flur 20 ---> _ Ordner G:\Daten\Teterow_1763\020 'Excel_Datei: G:\FF-Listen\Gemarkungen\1763-002.xls --> Zelltext:Teterow (1763), Fl. 2 ---> _ Ordner G:\Daten\Teterow_1763\002 'Excel_Datei: G:\FF-Listen\ungeprüft\1674-001.xls --> Zelltext:Altkalen (1674), Flur 1 ---> _ Ordner G:\Daten\Altkalen_1674\001_ohne FF-Liste Sub HL_Ü_automatisch() Dim Spalte As Long Dim varPath As Variant Dim strLink As String, strLinkLeft As String Dim iPos As Integer, iPos2 As Integer ActiveSheet.Unprotect For Spalte = 1 To 15 If Cells(2, Spalte) = "Gemarkung :" Then Spalte = Spalte + 2 Cells(2, Spalte).Select 'Zelle wird ausgewählt strLink = Cells(2, Spalte).Text '"(" im Link suchen iPos = InStr(1, strLink, "(") If iPos > 0 Then If Mid(strLink, iPos - 1, 1) = " " Then strLink = VBA.Replace(strLink, " (", "_") Else: strLink = VBA.Replace(strLink, "(", "") End If '")" im Link suchen iPos = InStr(iPos, strLink, ")") If iPos > 0 Then strLink = VBA.Replace(strLink, ")", "\") End If strLinkLeft = Left(strLink, iPos) 'Suchen nach der 1. Ziffer nach ")" iPos2 = iPos + 1 Do If IsNumeric(Mid(strLink, iPos2, 1)) Then Exit Do End If iPos2 = iPos2 + 1 Loop iPos = iPos2 'Position der Ziffer merken 'Suchen bis Zeichen nicht mehr nummerisch Do If Not IsNumeric(Mid(strLink, iPos2, 1)) Then varPath = Mid(strLink, iPos, iPos2 - iPos) strLink = strLinkLeft & Format(Val(varPath), "000") & Mid(strLink, iPos2) Exit Do ElseIf iPos2 = Len(strLink) Then varPath = Mid(strLink, iPos, iPos2 - iPos + 1) strLink = strLinkLeft & Format(Val(varPath), "000") Exit Do End If iPos2 = iPos2 + 1 Loop Dim pfad As String pfad = ActiveWorkbook.Path If InStr(1, pfad, "ungeprüft") > 0 Then strLink = strLink & "_ohne_FF-Liste" End If MsgBox "Hyperlinkadresse: " & vbLf & strLink 'Testzeile Worksheets(1).Hyperlinks.Add Anchor:=Selection, Address:=strLink 'Hyperlink wird _ eingefügt With Cells(2, Spalte).Font 'Zellformat .Name = "Arial" .Size = 12 .Underline = xlUnderlineStyleSingle .ColorIndex = 5 .TintAndShade = 0 .ThemeFont = xlThemeFontNone .Bold = True End With Else MsgBox "Zeichen ""("" im Link" & vbLf & strLink & vbLf & "nicht gefunden!" End If End If nextSpalte: Next Spalte MsgBox "Hyperlink gesetzt !!!" ActiveWorkbook.BuiltinDocumentProperties("Hyperlink base") = "\\fs02.lkros.local\Archiv62\ _ Zahlenwerk\Nachweise\" 'neue Hyperlinkbasis setzen ActiveWorkbook.FollowHyperlink (strLink) End Sub

End With MsgBox "Hyperlink gesetzt !!!" ActiveWorkbook.BuiltinDocumentProperties("Hyperlink base") = _ "\\fs02.lkros.local\Archiv62\Zahlenwerk\Nachweise\" 'neue Hyperlinkbasis setzen ActiveWorkbook.FollowHyperlink (strLink) Else MsgBox "Zeichen ""("" im Link" & vbLf & strLink & vbLf & "nicht gefunden!" End If End If nextSpalte: Next Spalte End Sub

Hallo Peter,
du hast Recht ich arbeite im Katasterwesen.
Der Zelltext soll so bleiben wie er ist. Aus dem Zelltext soll nur die Hyperlinkadresse entstehen, die an die Ordnerstruktur angepasst werden muss.
Dazu müssen die Leerzeichen durch _ ,die Klammer ( entfernt, die ) durch ein \ erstetzt, der Bereich von \ bis zur Flurnummer entfernt und die Flurnr. 3stellig werden.
Ich speichere das Makro in meiner persönlichen Arbeitsmappe, dort sind alle Makros gespeichert, die ich für die Überarbeitung der Tabellen benötige.
1. Makro zur Überarbeitung von Tabellenkopf und Formatierungen
2. Makro zur Überarbeitung alter Hyperlinks, anschließende Prüfung und Färbung (Ordnerstruktur hat sich geändert)
3. Makro für neue Hyperlinkbasis (Server ist neu)
4. dieses
5. muss noch: Neues Schutzmakro (beschrieben Zellen der Tabelle schützen, leer nicht)
Ich muss jede einzelne Datei öffnen, die Makros durchlaufen lassen und speichern. Automatisch geht das nicht, da ich manche Links noch manuell verändern muss.
Ich habe das Makro von Franz ein wenig gekürzt und verändert. Es macht was es soll. Falls du dich trotzdem noch versuchen möchtest oder auch nur einen Änderungsvorschlag hast, würde ich mich freuen.


Option Explicit
'Ziel:  In den FF-Listen steht in der 2. Zeile in irgendeiner Spalte der Gemarkungsname mit  _
Flur.
'       Hieraus möchte ich einen Hyperlink erstellen. Den vorhanden Zelltext nehme ich dafür  _
als Grundlage
'       und wandele ihn so ab, daß er zu Ordnerstruktur des Archivs passt.
'Excel_Datei: G:\FF-Listen\Gemarkungen\1763-020.xls --> Zelltext:Teterow (1763), Flur 20 --->   _
Ordner G:\Daten\Teterow_1763\020
'Excel_Datei: G:\FF-Listen\Gemarkungen\1763-002.xls --> Zelltext:Teterow (1763), Fl. 2   --->   _
Ordner G:\Daten\Teterow_1763\002
'Excel_Datei: G:\FF-Listen\ungeprüft\1674-001.xls   --> Zelltext:Altkalen (1674), Flur 1 --->   _
Ordner G:\Daten\Altkalen_1674\001_ohne FF-Liste
'klappt erstellt am 25.01.2017  (mit Hilfe von Franz aus dem Herbers Excel-Forum)
Sub HL_Überschrift()
Dim Spalte As Long
Dim varPath As Variant
Dim strLink As String, strLinkLeft As String
Dim iPos As Integer, iPos2 As Integer
ActiveSheet.Unprotect
For Spalte = 1 To 15
If Cells(2, Spalte) = "Gemarkung :" Then
Spalte = Spalte + 2
Cells(2, Spalte).Select 'Zelle wird ausgewählt
strLink = Cells(2, Spalte).Text
'"(" im Link suchen
iPos = InStr(1, strLink, "(")
If iPos > 0 Then
If Mid(strLink, iPos - 1, 1) = " " Then
strLink = VBA.Replace(strLink, " (", "_")
Else: strLink = VBA.Replace(strLink, "(", "")
End If
'")" im Link suchen
iPos = InStr(iPos, strLink, ")")
If iPos > 0 Then
strLink = VBA.Replace(strLink, ")", "\")
End If
strLinkLeft = Left(strLink, iPos)
'Die Zahl wird über die beiden Do-Loop-Schleifen ermittelt.
'In der 1. Do-Loop-Schleife läuft der Zähler iPos2 ab der Position nach ")" nach  _
rechts
'und prüft ob das Zeichen an der Position nummerisch ist. Diese Position wird in  _
iPos gespeichert.
'Suchen nach der 1. Ziffer nach ")"
iPos2 = iPos + 1
Do
If IsNumeric(Mid(strLink, iPos2, 1)) Then
Exit Do
End If
iPos2 = iPos2 + 1
Loop
iPos = iPos2 'Position der Ziffer merken
'In der 2. Do-Loop-Schleife läuft Zähler iPos2 weiter nach rechts bis das Zeichen  _
nicht nummerisch ist
'oder das Ende des Textes erreicht wird. Der Text von iPos bis iPos2-1 (bzw. iPos2  _
wenn Zahl am Ende des Textes)
'ist dann die Zahl und kann mit der Funktion Mid ermittelt werden.
'Suchen bis Zeichen nicht mehr nummerisch
Do
If Not IsNumeric(Mid(strLink, iPos2, 1)) Then
varPath = Mid(strLink, iPos, iPos2 - iPos)
strLink = strLinkLeft & Format(Val(varPath), "000") & Mid(strLink, iPos2)
Exit Do
ElseIf iPos2 = Len(strLink) Then
varPath = Mid(strLink, iPos, iPos2 - iPos + 1)
strLink = strLinkLeft & Format(Val(varPath), "000")
Exit Do
End If
iPos2 = iPos2 + 1
Loop
Dim pfad As String
pfad = ActiveWorkbook.Path
If InStr(1, pfad, "ungeprüft") > 0 Then
strLink = strLink & "_ohne_FF-Liste"
End If
MsgBox "Hyperlinkadresse: " & vbLf & strLink    'Testzeile
Worksheets(1).Hyperlinks.Add Anchor:=Selection, Address:=strLink  'Hyperlink wird  _
eingefügt
With Cells(2, Spalte).Font                  'Zellformat
.Name = "Arial"
.Size = 12
.Underline = xlUnderlineStyleSingle
.ColorIndex = 5
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
.Bold = True
End With
Else
MsgBox "Zeichen ""("" im Link" & vbLf & strLink & vbLf & "nicht gefunden!"
End If
End If
nextSpalte:
Next Spalte
MsgBox "Hyperlink gesetzt !!!"
ActiveWorkbook.BuiltinDocumentProperties("Hyperlink base") = "G:\Daten\" 'neue Hyperlinkbasis  _
setzen
ActiveWorkbook.FollowHyperlink (strLink)
End Sub

LG, Katjuscha

Hallo Katjuscha,
ich habe ein Programm entwickelt, mit dem Du m. E. einfacher arbeiten kannst. Der erforderliche Makro ist im Programm bereits enthalten. Es genügt die Eingabe von Pfad- und Dateiname in den gelb-unterlegten Feldern und ein Klick auf den Button. Wenn Du den Hyperlink überprüfen möchtest, gib bitte unten eine "1" ein. Eine Anpassung des Hyperlinks dürfte nicht erforderlich sein. Den Hyperlink habe ich in "C7" nach Deinen Angaben erstellt. Damit hatte ich jedoch bei meinen Tests keinen Erfolg. Es müssen Laufwerk und Pfadname vorangestellt werden ("C8"). Bei meinem Test habe ich bei den "Daten" für den Hyperlink Dateien vorausgesetzt. Wenn tatsächlich nur der Pfad im Hyperlink bezeichnet wird, kriegst Du das durch eine einfache Änderung in der Zelle "C8" hin: In der Formel '&".xlsx"' wegnehmen.
Ich empfehle, die geänderten Dateien in einen neuen Pfad abzuspeichern. Da nicht anzunehmen ist, dass Du in einem Rutsch alle 1.400 Dateien bearbeitest, weißt Du hinterher nicht, welche Datei nun umgesetzt wurde und welche nicht. Für meinen Test habe ich an die geänderten Dateien hinter der Dateinummer ein "A" angefügt. Aus folgendem Grund: Wenn man den Hyperlink überprüfen will, kann man eine gleichnamige Datei nicht laden. Wenn der Hyperlink nur den Pfad bestimmen soll, kann dies entfallen.
In den hellblau-unterlegten Feldern kannst Du Laufwerke und Pfade verändern.
Wenn Du willst, kannst Du meine Tests mit den beiliegenden Dateien nachvollziehen, oder gleich mit den Originaldaten testen. Welche Pfade mit welchen Dateien ich für meinen Test eingerichtet habe, geht aus den Hinweisen zur Datei "Umsetzung-Hyperlink" hervor.
Hier zunächst das Programm:
https://www.herber.de/bbs/user/110904.xlsm
Bitte speichere diese Datei mit dem Namen "Umsetzung_Hyperlink.xlsm" ab.
Die von mir verwendeten Testdateien
a) Dateien unter "FF_Listen"
https://www.herber.de/bbs/user/110905.zip
b) Dateien unter "Daten"
https://www.herber.de/bbs/user/110906.zip
Ich habe unter dem Laufwerk "G:" getestet; wenn Du mit diesem Laufwerk nicht testen kannst, weil es möglicherweise zu Kollisionen mit den Echtdaten kommt, kannst Du auch ein anderes Laufwerk wählen.
Wenn die Eingaben in den gelb-unterlegten Feldern zu viel Arbeit macht, könnte man auch eine Auflistung rechts neben dem Programmteil mit den Dateien eines angegebenen Pfades erstellen und durch Auswahl mit Rechtsklick auf den Dateinamen Pfad und Datei in den Programmteil übernehmen und gleichzeitig die Bearbeitung starten.
Viel Spaß beim Testen.
Mit freundlichem Gruß
Peter Kloßek

Beliebteste Forumthreads (12 Monate)

13 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread