Hallo zusammen,
das Programm ist jetzt etwas komplexer geworden und ich möchte noch einen Hyperlink hinzufügen, wüsste jemand für euch wie ich das mache?
Option Explicit
Dim objFileSystemObject As Object
Dim objDateien As Object
Dim objWeitereDateien As Object
Dim objDatei As Object
Dim lngFirstFreeRow As Long
Dim wksAuswertsheet As Worksheet
'###########################################################################################
'Autostart beim öffnen
Sub Auswertung_start()
'Zelleninhalte löschen
Cells.Select
Selection.ClearContents
'Objektverweise zuweisen
ChDir "\\LINK"
Set objFileSystemObject = CreateObject("Scripting.FileSystemObject")
Set objDateien = objFileSystemObject.getfolder("LINK")
Set wksAuswertsheet = ThisWorkbook.Sheets("Auswertung")
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$F$2"), , xlNo).Name = _
"Tabelle1"
Range("Tabelle1[#All]").Select
ActiveSheet.ListObjects("Tabelle1").TableStyle = "TableStyleMedium2"
Range("Tabelle1[[#Headers],[Spalte1]]").Select
ActiveCell.FormulaR1C1 = "BV-Merkmal"
Range("Tabelle1[[#Headers],[Spalte2]]").Select
ActiveCell.FormulaR1C1 = "Teilfreigabe"
Range("Tabelle1[[#Headers],[Spalte3]]").Select
ActiveCell.FormulaR1C1 = "Zuständigkeiten"
Range("Tabelle1[[#Headers],[Spalte4]]").Select
ActiveCell.FormulaR1C1 = "Anlagenbezeichnung"
Range("Tabelle1[[#Headers],[Spalte5]]").Select
ActiveCell.FormulaR1C1 = "Datum"
Range("Tabelle1[[#Headers],[Spalte6]]").Select
ActiveCell.FormulaR1C1 = "Bemerkung"
Call Dateien_auswerten
'Zuweisung wieder aufheben
Set objFileSystemObject = Nothing
Set objDateien = Nothing
Set wksAuswertsheet = Nothing
'Text aus Statusbar löschen
Application.StatusBar = ""
End Sub
'###########################################################################################
Sub Dateien_auswerten()
Application.ScreenUpdating = False
For Each objDatei In objDateien.Files
If Right(objDatei.Name, 4) = ".xls" Or Right(objDatei.Name, 5) = ".xlsx" _
Or Right(objDatei.Name, 5) = ".xlsm" Then
'erste freie Zelle in der Zieldatei in Spalte A ermitteln
lngFirstFreeRow = wksAuswertsheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
'Meldung in Statusbar anzeigen
Application.StatusBar = "Datei """ & objDatei.Name & """ wird ausgelesen!"
DoEvents
'Gefundene Datei unsichtbar öffnen
GetObject (objDatei)
'Wert aus geöffneter Datei aus dem Tabellenblatt 1 aus Zelle _
D20 in die erste freie Zelle in Spalte A übertragen
wksAuswertsheet.Cells(lngFirstFreeRow, 1) = _
Workbooks(objDatei.Name).Sheets(1).Range("D10")
'Wert aus geöffneter Datei aus dem Tabellenblatt 1 aus Zelle _
D20 in die erste freie Zelle in Spalte A übertragen
wksAuswertsheet.Cells(lngFirstFreeRow, 2) = _
Workbooks(objDatei.Name).Sheets(1).Range("D20")
'Wert aus geöffneter Datei aus dem Tabellenblatt 1 aus Zelle _
D20 in die erste freie Zelle in Spalte A übertragen
wksAuswertsheet.Cells(lngFirstFreeRow, 3) = _
Workbooks(objDatei.Name).Sheets(1).Range("F28")
wksAuswertsheet.Cells(lngFirstFreeRow, 4) = _
Workbooks(objDatei.Name).Sheets(1).Range("D12")
wksAuswertsheet.Cells(lngFirstFreeRow, 5) = _
Workbooks(objDatei.Name).Sheets(1).Range("G24")
'HYPERLINK
wksAuswertsheet.Hyperlinks.Add Anchor:=wksAuswertsheet.Cells(lngFirstFreeRow, 4), _
Address:="LINK" & "LINK" & objDatei.Name
'Geöffnete Datei wieder schließen ohne zu speichern
Workbooks(objDatei.Name).Close SaveChanges:=False
End If
Next
'Nächstes Verzeichnis abfragen
For Each objWeitereDateien In objDateien.subfolders
Set objDateien = objWeitereDateien
Call Dateien_auswerten
Next
End Sub
So funktioniert es leider NICHT, die hyperlinks erscheinen aber beim draufklicken wird die datei nicht geöffnet da ihm ein stück vom Pfad abgeht zwischen Ordner und objDatei.Name
bin dankbar für jeden TIPP
achja den LINK habe ich geteilt, da sonst der DATÉINAME + Pfad zu lang geworden ist.(über 256 Zeichen), kann man aber auch weglassen ändert nicht viel
:)
