title image


Smiley Re: Hyperlink erstellen ??????
Hallo Werner,Aller Guten Dinge sind Drei.Man muss halt nur hartnaeckig sein, wenn keine Antworten kommen!!! (Aber Du hast Urlaub gemacht und ich nicht!)Wenn ich Dich richtig verstanden habe moechtes Du zwar einerseits die Hyperlink-Moeglichkeit von Excel nutzen, aber nicht das kompletten Verzeichnis als Link angezeigt bekommen. Ansonsten koennte man ja einfach alle Dateien des Verzeichnisses als Link generieren.Nun, auch das kann man erreichen.Ich habe dafuer zwei Macros erstellt:Macro1 = ListFiles()listet alle Dateien (alle doc's) des Verzeichnisses in einer Excel Datei auf.Macro2 = OpenFile()erzeugt einen Link auf die jeweils ausgewaehlte Datei und ruft diesen auf.In dem Tabellenblatt muss jedoch ein Button vorhanden sein, welchem das Macro "OpenFile" zugewiesen wurde.Fuer diesen Button habe ich den Zellbereich A1:A2 vorgesehen.Notwendige Anpassungen sollten mit der Manipulation der Konstanten moeglich sein.Eine Fehlerroutine ist implementiert, diese kann jedoch nicht alle moeglichen Fehlerquellen abdecken und muesste je nach Einsatzgebiet ggf. noch verbessert werden.'Deklarationsbereich des Modules:Option ExplicitConst strPath As String = "D:\My Documents\" 'Pfad des Verzeichnisses ggf. anpassenConst strExt As String = "*.doc" 'Dateiextension ggf. anpassenConst strWorksheet As String = "Sheet1" 'Name des Tabellenblattes ggf. aendernConst strCell As String = "A3" 'Erste Zelle des Datenbereiches ggf. aendernConst strCellHL As String = "B1" 'Zelle des Hyperlinks ggf. aendern'End DeklarationSub ListFiles() Dim intCounter As Integer Dim strFile As String If strPath = "" Then Exit Sub Else strFile = Dir(strPath & strExt) intCounter = 0 ThisWorkbook.Sheets(strWorksheet).Range(strCell).Activate With ActiveCell Do While Len(strFile) > 0 .Offset(intCounter, 0).Value = strFile strFile = Dir() intCounter = intCounter + 1 Loop End With ActiveCell.Offset(intCounter, 0).Activate Range(ActiveCell, ActiveCell.End(xlDown)).Select Selection.ClearContents Range(strCell).Activate ActiveCell.Columns.AutoFit ActiveCell.Rows.Select ActiveWindow.FreezePanes = True End IfEnd SubSub OpenFile() Dim strCurrentCell As String strCurrentCell = ActiveCell.Address If ActiveCell.Value = "" Then GoTo InvalidCell ElseIf Range(strCellHL).Address = ActiveCell.Address Then GoTo InvalidCell Else On Error GoTo Errorhandle Application.ScreenUpdating = False Range(strCellHL).ClearContents With ActiveSheet .Hyperlinks.Add .Range(strCellHL), strPath & ActiveCell.Value End With Range(strCellHL).Select Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True Application.WindowState = xlNormal End If Range(strCellHL).ClearContents Range(strCurrentCell).Select Exit SubInvalidCell: MsgBox "Zuerst muss ein Dateiname aus " & vbCrLf & "der Liste ausgewaehlt werden!", vbOKOnly + vbExclamation, "Oeffnen einer Datei mit Hyperlink" Range(strCell).Activate Application.ScreenUpdating = True Exit SubErrorhandle: MsgBox "Die aufgelisteten Dateien befinden sich NICHT im angegeben Pfad!" & vbCrLf & strPath, vbOKOnly + vbExclamation Range(strCell).Activate Application.ScreenUpdating = TrueEnd SubViele GruesseNorbert

geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: