Hyperlinks

Bild

Betrifft: Hyperlinks
von: Yanno
Geschrieben am: 18.09.2015 12:50:00

Guten Tag
Habe folgendes vor:
Ich möchte in meiner Excel-Liste, die Zahlen (6 stellig) in Spalte A mit der jeweiligen Datei verlinken (Hyperlink) ( per Makro).
Ich habe 388 Zeilen und möchte nicht in jeder Zelle die Hyperlinks setzen, dies soll automatisch geschehen.
Dass blöde ist es soll mir z. B wenn in zelle X 739639,in Zelle Y 738646 und in Zelle Z 736123 steht jeweils überprüfen ob die ersten 3 Zahlen = 739 738 oder 736 sind und dann je nachdem in verschiedenen Ordnern die Datei(.xls, doc, docx)mit der jeweiligen nummern und pfad in der gleichen Zelle einen Hyperlink machen. Der Hyperlinkname (Anzuzeigender Text) sollte gleich sein wie vorher z. b 739123 (ohne Pfad ohne Dateityp).
Zum Beispiel in A1 steht: 739625
In A2 steht : 738124
Dann soll es prüfen A1 = 739XXX
also
if erste 3 zahlen = 739… then suche im Ordner C:\Users\brandty\_AHB das Dokument 739123.(doc, docx, xlm, pdf) wenn keine Datei mit 739625 dann mache nix sonst setze in Zelle A1 Hyperlink C:\Users\brandty\_AHB\734070&dateityp(gefunden) Anzuzeigender Text= Wert vorher in A1 „739123“
In A2:
if erste 3 zahlen = 738… then suche im Ordner C:\Users\brandty\_Qual das Dokument 738124.(doc, docx, xlm, pdf) wenn keine Datei mit 738124 dann mache nix sonst setze in Zelle A2 Hyperlink C:\Users\brandty\_AHB\734070+dateityp(gefunden)
Dies soll er von A1 – A500 (oder die ganze Spalte A) überprüfen und umsetzen
Meistens sind es Datetypen mit .doc oder .xltx.
Zudem sind es 8 verschieden Unterordner von C:\Users\brandty\ in der er schlussendlich je nachdem ob 731, 732, 733…739 als erste 3 Ziffern steht, nach der jeweiligen Datei suchen soll.
Ist es möglich, dies herzukriegen?
Vielen Dank
Yanno

Bild

Betrifft: AW: Hyperlinks
von: matthias
Geschrieben am: 18.09.2015 14:49:41
Hallo Yanno,
probier mal dies:

Sub Hyperlinks()
Dim x As Long
Dim sDateiname As String, sPfad As String, sEndung As String
For x = 1 To Cells(Rows.Count, 1).End(xlUp).Row
    sDateiname = CStr(Cells(x, 1).Value)
    'Ordner bestimmen
    Select Case Left(sDateiname, 3)
    Case "731": sPfad = "C:\Users\brandty\_Ordner1\"
    Case "732": sPfad = "C:\Users\brandty\_Ordner2\"
    Case "733": sPfad = "C:\Users\brandty\_Ordner3\"
    Case "734": sPfad = "C:\Users\brandty\_Ordner4\"
    Case "735": sPfad = "C:\Users\brandty\_Ordner5\"
    Case "736": sPfad = "C:\Users\brandty\_Ordner6\"
    Case "737": sPfad = "C:\Users\brandty\_Ordner7\"
    Case "738": sPfad = "C:\Users\brandty\_Qual\"
    Case "739": sPfad = "C:\Users\brandty\_AHB\"
    Case Is <> "739": GoTo NextZelle 'ungültiger Name
    End Select
    
    'Format bestimmen
    If Dir(sPfad & sDateiname & ".doc") <> "" Then
        sEndung = ".doc"
    ElseIf Dir(sPfad & sDateiname & ".docx") <> "" Then
        sEndung = ".docx"
    ElseIf Dir(sPfad & sDateiname & ".xlm") <> "" Then
        sEndung = ".xlm"
    ElseIf Dir(sPfad & sDateiname & ".pdf") <> "" Then
        sEndung = ".pdf"
    Else: GoTo NextZelle 'Datei nicht vorhanden
    End If
    
    'Hyperlink setzen
    With ActiveSheet
        .Hyperlinks.Add Anchor:=.Cells(x, 1), _
        Address:=sPfad & sDateiname & sEndung, _
        ScreenTip:=sPfad & sDateiname & sEndung, _
        TextToDisplay:=sDateiname
    End With
    
NextZelle:
Next x

Für die Formate bin ich nicht haftbar, die habe ich nur von dir abgeschrieben.
lg Matthias

Bild

Betrifft: AW: Hyperlinks
von: Yanno
Geschrieben am: 18.09.2015 17:52:23
Warte...
...
...
...
Einfach Weltklasse!!! Funkt.!
Ich dachte so wie ich dies beschreibe verstehts doch keiner, einmal mehr ein grosses Lob und an den Websitebetreiber!
Bin erstaunt wie schnell und perfekt der Code gemacht wurde.
P.S. Das End


Sub vergessen wir mal ;)
P.S.2. Gäbe es auch die Möglichkeit falls in Zelle 739863 steht, die Datei aber z.b so heisst " _
739863_in Arbeit" oder sonst ein Text noch da steht, dass dies mit dem Hyperlink auch funkt?
Vielen Vielen Dank 
Gruss
Yanno
Der Code wie ich ihn habe: 

Sub Hyperlinks()
Dim x As Long
Dim sDateiname As String, sPfad As String, sEndung As String
For x = 1 To Cells(Rows.Count, 1).End(xlUp).Row
    sDateiname = CStr(Cells(x, 1).Value)
    'Ordner bestimmen
    Select Case Left(sDateiname, 3)
    Case "731": sPfad = "G:\QMS\_AHB\3 Wrst und Mech\ALAW_1\"
    Case "732": sPfad = "G:\QMS\_AHB\3 Wrst und Mech\ARBAW_2\"
    Case "733": sPfad = "G:\QMS\_AHB\3 Wrst und Mech\PRAW_3\"
    Case "734": sPfad = "G:\QMS\_AHB\3 Wrst und Mech\SOP_4\"
    Case "735": sPfad = "G:\QMS\_AHB\3 Wrst und Mech\RICHT_5\"
    Case "736": sPfad = "G:\QMS\_AHB\3 Wrst und Mech\SPEZ_6"
    Case "738": sPfad = "G:\QMS\_AHB\3 Wrst und Mech\CHECK_8\"
    Case "739": sPfad = "G:\QMS\_AHB\3 Wrst und Mech\FORM_9\"
    Case Is <> "739": GoTo NextZelle 'ungültiger Name
    End Select
    
    'Format bestimmen
    If Dir(sPfad & sDateiname & ".doc") <> "" Then
        sEndung = ".doc"
    ElseIf Dir(sPfad & sDateiname & ".docx") <> "" Then
        sEndung = ".docx"
    ElseIf Dir(sPfad & sDateiname & ".dot") <> "" Then
        sEndung = ".dot"
    ElseIf Dir(sPfad & sDateiname & ".dotx") <> "" Then
        sEndung = ".dotx"
    ElseIf Dir(sPfad & sDateiname & ".xlm") <> "" Then
        sEndung = ".xlm"
    ElseIf Dir(sPfad & sDateiname & ".xltx") <> "" Then
        sEndung = ".xltx"
    ElseIf Dir(sPfad & sDateiname & ".xlsx") <> "" Then
        sEndung = ".xlsx"
    ElseIf Dir(sPfad & sDateiname & ".pdf") <> "" Then
        sEndung = ".pdf"
    Else: GoTo NextZelle 'Datei nicht vorhanden
    End If
    
    'Hyperlink setzen
    With ActiveSheet
        .Hyperlinks.Add Anchor:=.Cells(x, 1), _
        Address:=sPfad & sDateiname & sEndung, _
        ScreenTip:=sPfad & sDateiname & sEndung, _
        TextToDisplay:=sDateiname
    End With
    
NextZelle:
Next x
End Sub


Bild

Betrifft: AW: Hyperlinks
von: matthias
Geschrieben am: 22.09.2015 11:09:16

Hallo Yanno,
selbstverständlich geht das. Mit Hilfe eines "*" als Platzhalter beim Suchen der Datei ist das schnell erledigt:
Dim x As Long 'öffentlich
Sub Hyperlinks()
Dim sDateiname As String, sPfad As String, sEndung As String, sDateiExist As String
For x = 1 To Cells(Rows.Count, 1).End(xlUp).Row
    sDateiname = CStr(Cells(x, 1).Value)
 
    'Ordner bestimmen
    Select Case Left(sDateiname, 3)
    Case "731": sPfad = "G:\QMS\_AHB\3 Wrst und Mech\ALAW_1\"
    Case "732": sPfad = "G:\QMS\_AHB\3 Wrst und Mech\ARBAW_2\"
    Case "733": sPfad = "G:\QMS\_AHB\3 Wrst und Mech\PRAW_3\"
    Case "734": sPfad = "G:\QMS\_AHB\3 Wrst und Mech\SOP_4\"
    Case "735": sPfad = "G:\QMS\_AHB\3 Wrst und Mech\RICHT_5\"
    Case "736": sPfad = "G:\QMS\_AHB\3 Wrst und Mech\SPEZ_6"
    Case "738": sPfad = "G:\QMS\_AHB\3 Wrst und Mech\CHECK_8\"
    Case "739": sPfad = "G:\QMS\_AHB\3 Wrst und Mech\FORM_9\"
    Case Is <> "739"
        Call EntfHyperlink
        GoTo NextZelle 'ungültiger Name
    End Select
     
    'Format bestimmen
    sDateiExist = Dir(sPfad & sDateiname & "*")
    If sDateiExist = "" Then
        Call EntfHyperlink
        GoTo NextZelle 'Datei nicht vorhanden
    End If
    sEndung = Mid(sDateiExist, InStrRev(sDateiExist, "."))
     
    If sEndung = ".doc" Or _
        sEndung = ".docx" Or _
        sEndung = ".dot" Or _
        sEndung = ".dotx" Or _
        sEndung = ".xlm" Or _
        sEndung = ".xltx" Or _
        sEndung = ".xlsx" Or _
        sEndung = ".pdf" Then
    Else
        Call EntfHyperlink
        GoTo NextZelle 'ungültige Endung
    End If
    'Hyperlink setzen
    With ActiveSheet
        .Hyperlinks.Add Anchor:=.Cells(x, 1), _
        Address:=sPfad & sDateiExist, _
        ScreenTip:=sPfad & sDateiExist, _
        TextToDisplay:=sDateiname
    End With
     
NextZelle:
Next x
End Sub
Sub EntfHyperlink()
With Cells(x, 1)
If .Hyperlinks.Count > 0 Then .Hyperlinks.Delete
End With
End Sub

Nun wird zuerst ermittelt ob es eine Datei im Ordner gibt die mit der 6-stelligen Nummer anfängt (sDateiExist) und davon dann die Endung ermittelt. Der Rest ist bekannt.
Bei der Bennenung deiner Dateien musst du nur aufpassen, dass nichts vor der 6-stelligen Zahl steht und kein "." verwendet wird (außer bei der Endung). Ansonsten kannst du schreiben was du willst.
Als Ergänzung habe ich das zweite Makro eingebunden. Wenn in einer Zelle ein mittlerweile ungültiger Hyperlink vorhanden ist, wird dieser entfernt damit keine "Leichen" bleiben.
lg Matthias

Bild

Betrifft: AW: Hyperlinks
von: Yanno
Geschrieben am: 23.09.2015 18:14:18
Kommt bei mir eine Fehler (with Cells(x,1) bei diesem Code:

Sub EntfHyperlink()
With Cells(x, 1)
If .Hyperlinks.Count > 0 Then .Hyperlinks.Delete
End With
End Sub


Bild

Betrifft: AW: Hyperlinks
von: matthias
Geschrieben am: 24.09.2015 08:32:45
Hallo Yanno,
wenn es sich um den Laufzeitfehler 1004 - "Anwendungs- oder objektdefinierter Fehler" handelt, liegt das daran, dass du die Zeile Dim x As Long 'öffentlich vergessen hast. Diese MUSS oberhalb der ersten Makros stehn, so wie es auch im vorigen Post zu sehen ist. Damit ist die Variable x nicht nur auf ein Makro begrenzt, sondern kann von allen Makros innerhalb des Moduls genutzt werden. Falls ich es nicht erwähnt haben sollte: Beide Makros müssen im gleichen Modul stehen.
lg Matthias

 Bild

Beiträge aus den Excel-Beispielen zum Thema "Hyperlinks"