AW: Hyperlinks zu abweichenden Ordnernamen
06.10.2014 16:51:12
fcs
Hallo Tim,
wenn nur immer eine Zelle/Zeile mit einem Hyperlink versehen werdne soll, dann kann man die Makros etwa wie folgt aufbauen. Die Zelle, die den Hyperlink bekommen soll, wird dabei als Parameter übergeben.
Für die Änderung der Formatieung hab ich keine 100% Erklärung.
Das Einfügen eines Hyperlinks verändert jedoch ggf. die Schriftart/Farbe/Schriftgöße/Unterstreichung im Zellformat. Wenn das automatische Hyperlink-Format nicht gefällt, dann muss man nachträglich umformatieren.
Sub HyperlinksOrdner()
Dim strEingabe As String, Zeile As Long
Zeile = ActiveCell.Row
strEingabe = InputBox("Bitte Unterordner für Auftrag in Spalte B eingaben", _
"Ordner Spalte B")
If strEingabe "" Then
ActiveSheet.Cells(Zeile, 2) = "'" & strEingabe
Call HyperlinksOrdnerSpalteB(Zelle:=ActiveSheet.Cells(Zeile, 2))
End If
strEingabe = InputBox("Bitte Unterordner für Auftrag in Spalte E eingaben", _
"Ordner Spalte E")
If strEingabe "" Then
ActiveSheet.Cells(Zeile, 2) = "'" & strEingabe
Call HyperlinksOrdnerSpalteE(Zelle:=ActiveSheet.Cells(Zeile, 5))
End If
End Sub
Sub HyperlinksOrdnerSpalteB(Zelle As Range)
'Hyperlinks zu Auftragsordnern in Spalte B einfügen
Dim strText As String
Dim wks As Worksheet
Dim strPfad As String, strDir As String, strLink As String
strPfad = "Y:\Test\Auftraege" 'Basisverzeichnis für Aufträge - anpassen!
Set wks = Zelle.Parent 'Tab-Name anpassen!!
With wks
With Zelle
If .Hyperlinks.Count > 0 Then
.Hyperlinks(1).Delete
End If
strText = .Text
End With
If strText "" Then
strLink = ""
strDir = Dir(strPfad & Application.PathSeparator & strText, vbDirectory)
If strDir "" Then
strLink = strPfad & Application.PathSeparator & strText
Else
strText = strText & "*"
strDir = Dir(strPfad & Application.PathSeparator & strText, vbDirectory)
If strDir "" Then
strLink = strPfad & Application.PathSeparator & strDir
strText = strDir
End If
End If
If strLink = "" Then
MsgBox "In Zeile " & Zelle.Row & " kein Verzeichnis zu Auftrag """ _
& strText & """ gefunden", vbOKOnly, "Hyperlinks Spalte B"
Else
wks.Hyperlinks.Add anchor:=Zelle, Address:=strLink, _
ScreenTip:="Auftragsordner: " & strText
End If
With Zelle 'Formatierung anpassen
.HorizontalAlignment = xlCenter 'xlLeft xlRight
.VerticalAlignment = xlCenter 'xlTop xlBottom
With .Font
.Size = 8
.Name = "Calibri"
End With
.WrapText = False
End With
End If
End With
End Sub
Sub HyperlinksOrdnerSpalteE(Zelle As Range)
'Hyperlinks zu Auftragsordnern in Spalte E einfügen
Dim strText As String
Dim wks As Worksheet
Dim strPfad As String, strDir As String, strLink As String
strPfad = "Y:\Test\Auftraege" 'Basisverzeichnis - anpassen!!
Set wks = Zelle.Parent 'Tab-Name anpassen
With wks
With Zelle
If .Hyperlinks.Count > 0 Then
.Hyperlinks(1).Delete
End If
strText = .Text
End With
If strText "" Then
strLink = ""
strDir = Dir(strPfad & Application.PathSeparator & strText, vbDirectory)
If strDir "" Then
strLink = strPfad & Application.PathSeparator & strText
Else
strText = Left(strText, 8)
strDir = Dir(strPfad & Application.PathSeparator & strText, vbDirectory)
If strDir "" Then
strLink = strPfad & Application.PathSeparator & strDir
End If
End If
If strLink = "" Then
MsgBox "In Zeile " & Zelle.Row & " kein Verzeichnis zu Auftrag """ _
& strText & """ gefunden", vbOKOnly, "Hyperlinks Spalte E"
Else
wks.Hyperlinks.Add anchor:=Zelle, Address:=strLink, _
ScreenTip:="Auftragsordner: " & strText
End If
With Zelle 'Formatierung anpassen
.HorizontalAlignment = xlCenter 'xlLeft xlRight
.VerticalAlignment = xlCenter 'xlTop xlBottom
With .Font
.Size = 8
.Name = "Calibri"
End With
.WrapText = False
End With
End If
End With
End Sub