Dateiliste aktualisieren

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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

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

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

Beliebteste Forumthreads (12 Monate)

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread