Hyperlink per VBA erstellen
25.08.2003 13:26:54
thomasM
ich wollte einen Hyperlink per Vba erstellen. habe dazu schon das archive durchsucht, doch die lösungsvorschläge funktionieren bei mir nicht.
ich habe zum einen das ausgetestet:
ActiveCell.FormulaR1C1 = wksProjekt.Range("B3")
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=strVerzeichnis & strArray(intAktivArrayfeld)
und das:
wkbName = strVerzeichnis & strArray(intAktivArrayfeld)
With Workbooks(wksProjekt.Range("B3")).Worksheets(1)
intRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Hyperlinks.Add .Cells(intRow, 1), Address:=wkbName
End With
wobei die 1te version zwar kein fehler erzeugt jedoch auch keinen hyperlink.
es soll die zelle B4 aus der datei: strVerzeichnis & strArray(intAktivArrayfeld)
ausgelesen werden. (hab ich schon)
dann soll der inhalt in zelle: "A" & intZeileschreiben (in diesem Fall A4)
geschrieben werden. (hab ich auch schon)
nun wollte ich eine änderung reinbringen: der inhalt soll als hyperlink auf die datei eingefügt werden.
Beispiel:
datei: vorlage.xls
zellinhalt: test
in A4 soll jetzt ein hypelink stehen der auf die datei: sstrVerzeichnis & "\vorlage.xls" verweist. wenn man jetzt auf "test" klickt wird man sofort weitergeleitet zur datei.
soweit meine idee. ich hoffe ihr versteht was ich will.
wenn nciht hier nochmal der komplette code:
Option Explicit
Sub DateienAuflisten()
Dim lngAkt As Long
Dim rngBereich As Range
Dim rngZelle As Range
Dim wksIndex As Worksheet
Dim wksProjekt As Worksheet
Dim strZelle As String
Dim strZellinhalt As String
Dim strArray(1 To 50) As String
Dim wkbName As String
Dim intZeileLesen As Integer
Dim intZaehler As Integer
Dim intZeileSchreiben As Integer
Dim intAktivArrayfeld As Integer
Dim intBeschriebeneArrayfelder As Integer
Dim intSpalte As Integer
Dim intAnzahlDateien As Integer
Dim intRow As Integer
'Auslese Variablen
Dim strB3 As String
Dim strB4 As String
Dim strB5 As String
Dim strB6 As String
Dim strB8 As String
Dim strB9 As String
Dim strVerzeichnis As String
Set wksIndex = ThisWorkbook.Sheets(1)
Worksheets("Tabelle1").Range("A4:F65536").ClearContents
strVerzeichnis = Worksheets("Tabelle1").Range("H8").Value
With Application.FileSearch 'Hier werden alle Dateinamen aus einem Ordner
.NewSearch 'in Tabelle 2 Spalte A geschrieben
.LookIn = strVerzeichnis
.SearchSubFolders = False
.FileType = msoFileTypeExcelWorkbooks
.Execute
For lngAkt = 1 To .FoundFiles.Count
Cells(lngAkt, 1) = Mid(.FoundFiles.Item(lngAkt), Len(strVerzeichnis) + 1)
Next lngAkt
End With 'bis hier werden die Dateinamen in die
'Zellen (A1,A2,A3,...) geschrieben
intZeileLesen = 2
intZeileSchreiben = 4
intBeschriebeneArrayfelder = 1
strZelle = "A1"
intBeschriebeneArrayfelder = 0
intAktivArrayfeld = 1
strZellinhalt = "Anfang"
intAnzahlDateien = 0
Do Until strZellinhalt = "" 'Zellinhalte (Dateinamen) werden solange eingelesen bis die Zelle leer ist
strZellinhalt = Range(strZelle).Value 'Zellinhalt wird in Variable geschrieben
strArray(intAktivArrayfeld) = strZellinhalt 'schreibt Zellinhalt in Array
intAktivArrayfeld = intAktivArrayfeld + 1 'nächstes Arrayfeld wird aktiviert
strZelle = "A" & intZeileLesen
intZeileLesen = intZeileLesen + 1
intAnzahlDateien = intAnzahlDateien + 1
Loop
intBeschriebeneArrayfelder = intAktivArrayfeld - 1
For intAktivArrayfeld = 1 To intBeschriebeneArrayfelder - 1
Workbooks.Open strVerzeichnis & strArray(intAktivArrayfeld) 'Hier sollen die Zellinhalte einzeln
Set wksProjekt = ActiveWorkbook.Sheets(1) 'in das Indexblatt geschrieben werden
wksIndex.Range("B" & intZeileSchreiben) = wksProjekt.Range("B3")
Set wksProjekt = ActiveWorkbook.Sheets(1)
wksIndex.Range("A" & intZeileSchreiben) = wksProjekt.Range("B4")
Hyperlink hierhin 'ActiveCell.FormulaR1C1 = wksProjekt.Range("B3")
'ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=strVerzeichnis & strArray(intAktivArrayfeld)
'wkbName = strVerzeichnis & strArray(intAktivArrayfeld)
'With Workbooks(wksProjekt.Range("B3")).Worksheets(1)
' intRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
' .Hyperlinks.Add .Cells(intRow, 1), Address:=wkbName
'End With
Set wksProjekt = ActiveWorkbook.Sheets(1)
wksIndex.Range("C" & intZeileSchreiben) = wksProjekt.Range("B5")
Set wksProjekt = ActiveWorkbook.Sheets(1)
wksIndex.Range("D" & intZeileSchreiben) = wksProjekt.Range("B6")
Set wksProjekt = ActiveWorkbook.Sheets(1)
wksIndex.Range("E" & intZeileSchreiben) = wksProjekt.Range("B8")
Set wksProjekt = ActiveWorkbook.Sheets(1)
wksIndex.Range("F" & intZeileSchreiben) = wksProjekt.Range("B9")
Workbooks(Right(strArray(intAktivArrayfeld), Len(strArray(intAktivArrayfeld)) - 1)).Close SaveChanges:=False
intZeileSchreiben = intZeileSchreiben + 1
strArray(intAktivArrayfeld) = ""
Next
Worksheets("Tabelle2").Range("A1:A" & intAnzahlDateien).Delete 'Hier soll der Inhalt von Spalte A gelöscht werden
End Sub
danke vielmals im vorraus,
thomasM