Office: Dateiliste erstellen mit Hyperlink und wert aus einer bestimmten Zelle hinzufügen

Hallo zusammen,


mein Problem ist folgendes:
ich habe eine Exceldatei zur Projektübersicht erstellt. Jeder neue Kunde ist ein neues Projekt und wird über Makro in einem Ordner unter einen generiertem Dateinamen gespeichert.
In jedem Projekt (in jeder Exceltabelle) habe ich in einer bestimmten Zelle einen Wert stehen (Projektstatus in %)

ich möchte folgendes erreichen:
1. Aus einem neuen Worksheet heraus per Makro den Ordner auslesen, in dem sich alle Projektdateien befinden.
2. Die Dateinamen in eine Spalte ("B") schreiben.
3. In Spalte ("C") zu jeder gefundenen Datei einen Hyperlink setzen. (Ich möchte von hier aus direkt zu den einzelnen Dateien wechseln können.
4. In Spalte ("D") aus den betreffenden Dateien die Celle ("§C§3") auslesen und den Wert hier eintragen.

Der Ordnerpfad sollte automatisch ermittelt werden (es ist derselbe, in dem sich die Übersichtsdatei befindet.

Ich habe verschiedene Makros im Netz gefunden und getestet.
Zwar funktioniert mittlerweile das was ich möchte, aber eben noch nicht reibungslos.
Ich verwende für das auslesen der Dateinamen ein Makro, für das Auslesen der Zelle C3 ein zweites. beide Makros habe ich hintereinandergehängt.

Ich habe hierbei das Problem, das sich ein Fenster zur Ordnerauswahl öffnet, in dem ich immer erst hin und herklicken muss damit die Dateien ausgelesen werden können.
Dieses Makro könnte auch Unterordner einbeziehen, was ich aber definitiv nicht benötige.
In meinem Fall liegen alle Dateien im selben Ordner.

Für eine unkomplizierte Lösung sage ich jetzt schon einmal danke.

Eines vielleicht ist auch noch wichtig, das sollte auf 2003 und 2007er Excel laufen, da wir beide Versionen verwenden.

Meinen verwendeten Code poste ich gleich noch dazu.

:)

 

Private Sub CommandButton1_Click()

'*****************************************
'** Auswahl des auszuwertenden Ordner **
'*****************************************
Dim Pfad As String, i As Long

With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = ThisWorkbook.Path
.Title = "Ordnerauswahl"
.ButtonName = "Auswahl..."
.InitialView = msoFileDialogViewList
If .Show = -1 Then
Pfad = .SelectedItems(1)
Else
Exit Sub
End If
End With

'*****************************************
'** Tabelle vorbereiten **
'*****************************************


Cells.ClearContents
[A1].Select
[A1:F1] = Array("No.", "Path", "Filename", "Date", "Link", "Status")
[A1:F1].Font.Bold = True

'[C:C].WrapText = True
'[C:C].ColumnWidth = 20
'[D].NumberFormat = "yyyy.mm.dd"
'[D].ColumnWidth = 10
'[A1:F1].Interior.ColorIndex = 8



'************************************************* *******
'** Sub list_files aufrufen , Spaltenbreite anpassen **
'************************************************* *******

Call list_files([A2:F2], CreateObject("Scripting" & _
".FileSystemObject").GetFolder(Pfad))
[A:E].EntireColumn.AutoFit


'************************************************* ***
'** Dateien nach Unterordner/Dateiname sortieren **
'************************************************* ***

Range("A1").Sort _
Key1:=Range("B2"), Order1:=xlAscending, _
Key2:=Range("C2"), Order2:=xlAscending, _
Header:=xlYes

For i = 2 To Range("B" & Rows.Count).End(xlUp).Row
'Nummerieren
Range("A" & i) = i - 1
'Hyperlink hinzufügen
ActiveSheet.Hyperlinks.Add _
Anchor:=Range("E" & i), _
Address:=Range("B" & i) & IIf(Len(Range("B" & i)) > 0, "\" & _
"", "") & Range("C" & i), TextToDisplay:="Link"
Next
End Sub

'*****************************************
'** Dateien listen **
'*****************************************
Sub list_files(r As Range, ordner As Variant)


Dim file As Variant
Dim subordner As Variant
Dim wb As Workbook
Dim objShell, objFolder, objFile As Object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(CStr(ordner))

On Error GoTo ende
Application.ScreenUpdating = False

For Each file In ordner.Files
Set objFile = objFolder.ParseName(CStr(file.Name))

r(2) = Replace(ordner.Path, ThisWorkbook.Path & "\", "")
r(3) = file.Name
r(4) = DateValue(file.DateLastModified)
r(6) = objFolder.GetDetailsOf(objFile, 14)

Set r = r.Offset(1)
Next

For Each subordner In ordner.SubFolders
If (subordner.Attributes And 4) = 0 Then '/System-Ordner/
Call list_files(r, subordner)
End If
Next

Range("A1").Select
ende:
Application.ScreenUpdating = True
'End Sub


'Private Sub CommandButton2_Click()

Dim datei As String
Dim i As Integer
i = 0
datei = Dir(ThisWorkbook.Path & "\*.xls")
Rows("2:2").Select
Selection.Delete Shift:=xlUp
While datei ""
i = i + 1
If datei ThisWorkbook.Name Then
ThisWorkbook.Worksheets("Tabelle1").Cells(i, 6).Formula = "='" & ThisWorkbook.Path & "\[" & datei & "]Facts'!$C$3"
End If
datei = Dir
Wend


End Sub

 

Hallo Bernd,

probier mal.

HINWEIS:
Bei der Zeile

musst du "Tabelle1" durch deinen Tabellennamen "Facts" ersetzen!



Gruß Sepp

 

Hallo Sepp,

nachdem ich im Code den Namen der Tabelle von "Tabelle1" auf "Facts" geändert habe war alles perfekt.
Das hattest Du ja auch schon geschrieben :-)

Vielen Dank für Deine schnelle Hilfe!!

Eines ist mir hierbei noch aufgefallen:
was müsste ich im Code ändern, damit die Tabelle sich nicht selbst erkennt und auflistet?

Bernd

 

Hallo Bernd,

sorry, das hab' ich übersehen.




Sub listFiles()
Dim objFiles() As Object, lngI As Long, lngRet As Long, lngRow As Long
Dim strPath As String

On Error GoTo ErrExit

With ActiveSheet
.Range("A2:F" & .Rows.Count).ClearContents
Application.ScreenUpdating = False
strPath = .Parent.path

lngRet = FileSearchINFO(objFiles, strPath, "*.xls*", True)

If lngRet > 0 Then
lngRow = 1
For lngI = 0 To lngRet - 1
If objFiles(lngI).Name <> .Parent.Name Then
lngRow = lngRow + 1
.Cells(lngRow, 2) = objFiles(lngI).parentfolder.path
.Cells(lngRow, 3) = objFiles(lngI).Name
.Cells(lngRow, 4) = objFiles(lngI).DateLastModified
.Hyperlinks.Add Anchor:=.Cells(lngRow, 5), Address:=CStr(objFiles(lngI)), SubAddress:="", TextToDisplay:="Link"
.Cells(lngRow, 6) = GetValue(.Cells(lngRow, 2).Text, .Cells(lngRow, 3).Text, "Facts", "C3")
End If
Next
.Columns.AutoFit
.Range("A1").CurrentRegion.Sort _
Key1:=.Range("B2"), Order1:=xlAscending, _
Key2:=.Range("C2"), Order2:=xlAscending, _
Header:=xlYes
With .Range("A2:A" & lngRow)
.Formula = "=ROW()-1"
.Value = .Value
End With

End If


End With


ErrExit:
Application.ScreenUpdating = True
End Sub



Gruß Sepp

 

Super,

absolut perfekt.

Vielen Dank für Deine Hilfe

 

Hallo zusammen,

erstmal vorweg, super Code und nimmt mir wirklich viel Arbeit ab. *Smilie

Sagt mal ist es möglich diesen Code auch so umstricken, dass er folgendes noch kann:

Ich speichere alle Dateien wie folgt:

Datum/Kundennr z. B. 20110708_5000

Was ich nun bräuchte war:

Durch die Kundennr. wird der Ordner festgelegt und diese sollte somit in den Pfad für den Ordner übernommen werden. Damit listet er dann nur die Dateien in dem richtigen Kundenordner auf.

Das wäre genial, wenn es dafür noch eine Lösung gibt. *rolleyes.gif*

Danke im Voraus. *mrcool

 

Hallo zusammen

ich bin ziemlich neu hier und konnte mir einiges "zusammenbasteln" mit Hilfe des Forums - vielen Dank schon einmal an alle Poster!

Nun habe ich aber ein Problem, aufwelches ich nirgends eine Lösung gefunden habe...
Ich Liste per VBA in einer Tabelle alle Dateien eines Unterordners auf.
In der
1. Spalte Nummeriert es mir die Dateien durch
2. Spalte (diese ist mein Problem, dazu komme ich nachher)
3. Spalte die Dateinamen inkl Hyperlink auf die Datei
4. Spalte den Dateipfad
5. Spalte das Änderungsdatum

nun möchte ich, dass in der 2. Spalte jeweils "löschen" steht und ich mit einem klick darauf die Datei löschen kann. Dabei spielt es keine Rolle ob diese in den Papierkorb oder ganz gelöscht wird....

Hier nun mal der Code den ich benutze (ist auch aus diesem Forum):

Code:

Vielen Dank schon jetzt für die Hilfe

Gruss
Hermre

 

Hallo ?,

Diesen Code in die entsprechenden Module.

' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Column = 2 Then
Cancel = True
If Target = "Löschen" Then
If Target.Offset(0, 1).Hyperlinks.Count > 0 Then
If Dir(Target.Offset(0, 1).Hyperlinks(1).Address, vbNormal) <> "" Then
Me.Unprotect "XXXX"
Kill Target.Offset(0, 1).Hyperlinks(1).Address
Target.EntireRow.Delete
Me.Protect "XXXX"
End If
End If
End If
End If
End Sub

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub listFiles()

ActiveSheet.Unprotect Password:="XXXX"

Dim objFiles() As Object, lngI As Long, lngRet As Long, lngRow As Long
Dim StrPath As String

On Error GoTo ErrExit

With ActiveSheet
.Range("A3:G" & .Rows.Count).ClearContents
Application.ScreenUpdating = False
StrPath = "\\192.168.1.200\dokumente\VerwaltungBetrieb\archiv"

lngRet = FileSearchINFO(objFiles, StrPath, "*.pdf;*.xlsm;*.doc;*.docx", True)

If lngRet > 0 Then
lngRow = 3
For lngI = 0 To lngRet - 1
If objFiles(lngI).Name <> .Parent.Name Then
lngRow = lngRow + 1
.Cells(lngRow, 2) = "Löschen"
.Hyperlinks.Add Anchor:=.Cells(lngRow, 3), Address:=CStr(objFiles(lngI)), SubAddress:="", TextToDisplay:=objFiles(lngI).Name
.Cells(lngRow, 4) = objFiles(lngI).parentfolder.Path
.Cells(lngRow, 5) = objFiles(lngI).DateLastModified
.Cells(lngRow, 6) = GetValue(.Cells(lngRow, 2).Text, .Cells(lngRow, 3).Text, "Facts", "C3")

End If
Next

.Range("A3").CurrentRegion.Sort _
Key1:=.Range("C3"), Order1:=xlDescending, _
Key2:=.Range("D3"), Order2:=xlDescending, _
Key3:=.Range("E3"), Order3:=xlAscending, _
Header:=xlNo
With .Range(.Cells(3, 1), .Cells(lngRow - 1, 1))
.Formula = "=ROW()-2"
.Value = .Value
End With
End If


End With


ErrExit:
Application.ScreenUpdating = True


ActiveSheet.Protect Password:="XXXX"

End Sub

Private Function FileSearchINFO(ByRef Files() As Object, ByVal InitialPath As String, Optional ByVal FileName As String = "*", _
Optional ByVal SubFolders As Boolean = False) As Long

'# PARAMETERINFO:
'# Files: Datenfeld zur Ausgabe der Suchergebnisse
'# InitialPath: String der das zu durchsuchende Verzeichnis angibt
'# FileName: String der den gesuchten Dateityp oder Dateinamen enthält (Optional, Standard="*.*" findet alle Dateien)
'# Beispiele: "*.txt" - Findet alle Textdateien
'# "*name*" - Findet alle Dateien mit "name" im Dateinamen
'# "*.avi;*.mpg" - Findet .avi und .mpg Dateien (Dateitypen mit ; trennen)
'# SubFolders: Boolean gibt an, ob Unterordner durchsucht werden sollen (Optional, Standard=False)


Dim fobjFSO As Object, ffsoFolder As Object, ffsoSubFolder As Object, ffsoFile As Object
Dim intC As Integer, varFiles As Variant

Set fobjFSO = CreateObject("Scripting.FileSystemObject")

Set ffsoFolder = fobjFSO.GetFolder(InitialPath)

On Error GoTo ErrExit

If InStr(1, FileName, ";") > 0 Then
varFiles = Split(FileName, ";")
Else
Redim varFiles(0)
varFiles(0) = FileName
End If

For Each ffsoFile In ffsoFolder.Files
If Not ffsoFile Is Nothing Then
For intC = 0 To UBound(varFiles)
If LCase(fobjFSO.GetFileName(ffsoFile)) Like LCase(varFiles(intC)) Then
If IsArray(Files) Then
Redim Preserve Files(UBound(Files) + 1)
Else
Redim Files(0)
End If
Set Files(UBound(Files)) = ffsoFile
Exit For
End If
Next
End If


Next

If SubFolders Then
For Each ffsoSubFolder In ffsoFolder.SubFolders
FileSearchINFO Files, ffsoSubFolder, FileName, SubFolders
Next
End If

If IsArray(Files) Then FileSearchINFO = UBound(Files) + 1
ErrExit:
Set fobjFSO = Nothing
Set ffsoFolder = Nothing
End Function

Private Function GetValue(Path As String, file As String, _
sheet As String, ref As String)
' Retrieves a value from a closed workbook
Dim arg As String
' Make sure the file exists
If Right(Path, 1) <> "\" Then Path = Path & "\"

If Dir(Path & file) = "" Then
GetValue = "File Not Found"
Exit Function
End If

' Create the argument
arg = "'" & Path & "[" & file & "]" & sheet & "'!" & _
Range(ref).Range("A1").Address(, , xlR1C1)

' Execute an XLM macro
GetValue = ExecuteExcel4Macro(arg)
End Function



Ein Doppelklick auf "Löschen" löscht die Datei und entfernt die Zeile.



« Gruß Sepp »

 

Hallo Josef

vielen Dank schon einmal, mache mich gleich daran und versuche deinen Code einzupassen - melde mich wieder....

Gruss
Hermre

 

Hallo

vielen, vielen Dank klappt perfekt!!!
Noch eine (kleine?) Frage - wie kann ich das ganze um eine Spalte verschieben (nach rechts)?

 

Entschuldige, ich Dösel sollte alles lesen.... Habe es geschafft!