ich habe folgendes Problem in Excel 2003:
In einer Tabelle sind in einer Spalte Dateinamen aufgelistet.
Nun möchte ich in einer Schleife per VBA alle gleichnamigen Dateien suchen und bei jedem Fund den Hyperlink (ganzer Pfad + Dateiname) in eine neue Zelle in der betreffenden Zeile schreiben lassen. Wird nichts gefunden, so soll die Hyperlink-Zelle leer bleiben. Gesucht werden soll in einem bekannten Verzeichnis samt Unterverzeichnissen.
Hat jemand eine Idee?
Vielen Dank schon mal.
hier ein VBA-Code, denn du noch ein wenig anpassen musst bzgl.
Verzeichnis, Spalte mit Dateinamen, Spalten-Offset für Zelle mit Hyperlink.
Gruß
Franz
'Code in einem allgemeinen Modul einfügen
Public lCount As Long, arrFiles() As String
Sub ListFilesInFolder(ByVal SourceFolderName As String, \_
Optional ByVal DateiFormat As String = "\*.\*", \_
Optional ByVal IncludeSubfolders As Boolean = False)
'1.Parameter Ordner, wo soll gesucht werden?
'2.Parameter Datei,\* als Platzhalter verwenden,Optional leer ist alle
'3.Parameter mit Unterordner = True, Optional False ist ohne
'Erstellt gemäß Suchkriterien ein Array mit den Dateinamen
Dim FSO As Object, SourceFolder As Object, SubFolder As Object
Dim FileItem
Dim Status As Integer
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(SourceFolderName)
On Error GoTo Err\_Zugriff: 'sollte Ordner geschützt sein
For Each FileItem In SourceFolder.Files
If LCase(FileItem.Name) Like LCase(DateiFormat) Then
lCount = lCount + 1
ReDim Preserve arrFiles(1 To 2, 1 To lCount)
arrFiles(1, lCount) = FileItem
arrFiles(2, lCount) = FileItem.Name
End If
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder.Path, DateiFormat, IncludeSubfolders
Next SubFolder
End If
Err\_Zugriff:
Set FileItem = Nothing: Set SourceFolder = Nothing: Set FSO = Nothing
End Sub
Sub HyperlinksEinfuegen()
Dim wks As Worksheet, Zelle As Range, sDateiname As String, iOffset As Integer, lFile As Long
Dim sVerzeichnis As String
sVerzeichnis = "C:\Users\Public\Test"
Set wks = ActiveSheet
'Liste mit allen Dateinamen erstellen
lCount = 0
Erase arrFiles
Call ListFilesInFolder(SourceFolderName:=sVerzeichnis, \_
DateiFormat:="\*.\*", IncludeSubfolders:=True)
With wks
'Zellen in Spalte 1(A) mit den Dateinamen abarbeiten
For Each Zelle In .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
sDateiname = UCase(Zelle.Text)
If sDateiname "" Then
iOffset = 0 'Startoffset für Hyperlinkzelle 0 = rechte Nachbarzelle
For lFile = 1 To lCount
If UCase(arrFiles(2, lFile)) = sDateiname Then
iOffset = iOffset + 1
'Hyperlinks in rechter Nachbarzelle einfügen
wks.Hyperlinks.Add Anchor:=Zelle.Offset(0, iOffset), Address:=arrFiles(1, lFile)
Zelle.Offset(0, iOffset).Value = arrFiles(1, lFile)
Exit For 'Diese Zeile löschen, wenn identische Dateinamen in mehreren \_
Unterverzeichnissen vorkommen können.
End If
Next
End If
Next Zelle
End With
End Sub