Thema: Dateiliste aktualisieren | Herbers Excel-Forum

Hallo, zusammen,
folgendes Problemchen: Ich bastle an einem Makro, das alle Dateien (jpg) in einem Ordner einschließlich Unterordner sucht, die Dateinamen ohne Pfad in eine Excel Liste einträgt und die Dateien gleich per Hyperlink verknüpft. Das klappt bisher auch ganz gut. Das Problem ist, dass die Dateien ständig mehr werden und ich die Liste gerne aktualisieren möchte, so dass vorhandene Einträge nicht gelöscht werden, neue nur ergänzt (im Spalte 2 und 3 trage ich anschließend von Hand weitere Informationen ein). Das u.s. Makro löscht jedsmal die gesamte Spalte und legt sie neu an. Das führt dazu, dass die Einträge in Spalte 2 und 3 nicht mehr zu den Einträgen in Spalte 1 passen. Könnte mir jemand bitte helfen, das Makro anzupassen?
Vielen Dank im Voraus,
Heiko

Sub Hyperlinks_einfügen()
Worksheets(1).Columns(1).Clear
With Application.FileSearch
.NewSearch
.LookIn = "C:\Pfad\Pfad\Pfad\Bilder"
.Filename = "*.jpg"
.SearchSubFolders = True
.Execute
icount = .FoundFiles.Count
For i = 1 To icount
Worksheets(1).Hyperlinks.Add anchor:=Worksheets(1).Cells(i, 1), Address:=.FoundFiles(i)
For j = Len(Cells(i, 1)) To 1 Step -1
If Cells(i, 1).Characters(j, 1).Text = "\" Then
Cells(i, 1) = Right(Cells(i, 1), Len(Cells(i, 1)) - j)
Exit For
End If
Next j
Next i
End With
End Sub

Hallo Heiko
Versuch mal diesen Code:

Sub Hyperlinks_einfügen()
Dim lloZeile As Long, lboTreffer As Boolean, lloLetzte As Long
'Worksheets(1).Columns(1).Clear
With Application.FileSearch
.NewSearch
.LookIn = "D:\Thorsten Gobrecht\Fotos\Schlazi"
.Filename = "*.jpg"
.SearchSubFolders = True
.Execute
icount = .FoundFiles.Count
For i = 1 To icount
For lloZeile = 1 To Cells(Rows.Count, 1).End(xlUp).Row
If Range("A" & lloZeile).Hyperlinks.Count > 0 Then
If Range("A" & lloZeile).Hyperlinks(1).Address = .FoundFiles(i) Then
lboTreffer = True
Exit For
End If
End If
Next
If lboTreffer = True Then
lboTreffer = False
Else
lloLetzte = IIf(Range("A" & Cells(Rows.Count, 1).End(xlUp).Row).Value = "" And  _
Cells(Rows.Count, 1).End(xlUp).Row = 1, Cells(Rows.Count, 1).End(xlUp).Row, Cells(Rows.Count, 1).End(xlUp).Row + 1)
Worksheets(1).Hyperlinks.Add anchor:=Worksheets(1).Cells(lloLetzte, 1), Address: _
=.FoundFiles(i)
For j = Len(Cells(lloLetzte, 1)) To 1 Step -1
If Cells(lloLetzte, 1).Characters(j, 1).Text = "\" Then
Cells(lloLetzte, 1) = Right(Cells(lloLetzte, 1), Len(Cells(lloLetzte, 1) _
) - j)
Exit For
End If
Next j
End If
Next i
End With
End Sub

Du musst/kannst die von der Forumssoftware eingefügten Zeilenumbrüche entfernen.
Hilfts denn?
Ciao
Thorsten

hi, Thorsten,
vielen Dank für den Code. Leider klappts noch nicht richtig. Der neue Code hänt alle Dateien einfach an die alte liste hinten dran, so dass die meisten nun doppelt vorhanden sind.
Müsste doch schon gehen, dass für jede gefundenen Datei erstmal die Liste geprüft wird, ob der Eintrag schon da ist und nur wenn nicht, dass der Eintrag am Ende der Liste angefügt wird, oder?
Grüße, Heiko

Hi Heiko
Versuch es so:

Sub Hyperlinks_einfügen()
Dim lloZeile As Long, lboTreffer As Boolean, lloLetzte As Long, lstrRG As String, lstrHL As  _
String
'Worksheets(1).Columns(1).Clear
With Application.FileSearch
.NewSearch
.LookIn = "D:\Thorsten Gobrecht\Fotos\Schlazi"
.Filename = "*.jpg"
.SearchSubFolders = True
.Execute
icount = .FoundFiles.Count
For i = 1 To icount
For lloZeile = 1 To Cells(Rows.Count, 1).End(xlUp).Row
If Range("A" & lloZeile).Hyperlinks.Count > 0 Then
lstrRG = Range("A" & lloZeile).Hyperlinks(1).Address
lstrHL = .FoundFiles(i)
If Mid(lstrHL, 2, 1) = ":" And Mid(lstrRG, 2, 1) <> ":" Then lstrHL = Right( _
lstrHL, Len(lstrHL) - 3)
lstrHL = Replace(lstrHL, "\", "/")
lstrRG = Replace(lstrRG, "\", "/")
If lstrHL = lstrRG Then
lboTreffer = True
Exit For
End If
End If
Next
If lboTreffer = True Then
lboTreffer = False
Else
lloLetzte = IIf(Range("A" & Cells(Rows.Count, 1).End(xlUp).Row).Value = "" And  _
Cells(Rows.Count, 1).End(xlUp).Row = 1, Cells(Rows.Count, 1).End(xlUp).Row, Cells(Rows.Count, 1).End(xlUp).Row + 1)
Worksheets(1).Hyperlinks.Add anchor:=Worksheets(1).Cells(lloLetzte, 1), Address: _
=.FoundFiles(i)
For j = Len(Cells(lloLetzte, 1)) To 1 Step -1
If Cells(lloLetzte, 1).Characters(j, 1).Text = "\" Then
Cells(lloLetzte, 1) = Right(Cells(lloLetzte, 1), Len(Cells(lloLetzte, 1) _
) - j)
Exit For
End If
Next j
End If
Next i
End With
End Sub

Hilfts?
Ach so, es wird im Code aber nicht geprüft, ob du vielleicht die eine oder andere Bilddatei gelöscht hast - will sagen: alle Einträge in der Datei bleiben....auch wenn die dazugehörige Bilddatei nicht mehr vorhanden ist.
Aber das war ja auch nicht Bestanddteil deiner Frage.
Bin neugierig auf deine Antwort.
Ciao
Thorsten