Bilder in einem Ordner auslesen und sortieren

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo,
erst mal ein großes Kompliment, dass ist das erste Forum in dem ich tatsächlich mal eine Antwort auf eine Frage/Beitrag bekomme.
Ich habe das Ganze vielleicht etwas verwirrend erklärt.
Ich habe einen Ordner in dem sich Bilddaten zu unseren Artikel befinden, zu manchen Artikeln gibt es nur ein Bild, zu den meisten gibt es mehrer Bilder.
Ich möchte nun das alle Bildnamen in einer Exceltabelle aufgelistet werden.
Diese Makro Habe ich schon:

Sub Auslesen()
Dim fs As Object
Dim fVerz As Object
Dim fDatei As Object
Dim fdateien As Object
Dim strDat As String
Dim Zeile As Integer
Set fs = CreateObject("scripting.FileSystemObject")
Set fVerz = fs.getFolder("Link/zum/Ordner")
Set fdateien = fVerz.Files
For Each fDatei In fdateien
If InStr(fDatei, "") > 0 Then
Zeile = Zeile + 1
Cells(Zeile, 1) = fDatei.Name
End If
Next fDatei
End Sub

Das passt aber nicht so gut.
Es wäre gut wenn ich den Link zu dem Ordner in z.B. in Zelle C2 eintrage und das Makro dies dann erkennt und die Bildnamen ausließt, noch besser wäre wenn ich den Link zum Ordner direkt in einer MsgBox eintrage.
Und dann kommt der 2te Schritt:
Die Bildnamen werden in der Tabelle fortlaufen untereinander Dargestellt und zusätzlich werden Bilder die zum selben Artikel gehören in den Spalten neben dem Hauptbild dargestellt.
Ich versuch gerade mal schnell eine Excel Liste hochzuladen dort kann man in Tabellenblatt 2 sehen wie ich mir das Ergebnis Vorstelle.
Was man zusätlich noch beachten sollte ist, dass es zu manchen Artikeln mehr als 10 Bilder gibt ich benötige aber dann nur die Bildnamen der ersten 10.
Vorab schon mal vielen lieben Dank für die Hilfe!

Sub a() Dim Wb As Workbook: Set Wb = ThisWorkbook Dim Ws As Worksheet: Set Ws = Wb.Worksheets("Beispiel") Dim Dlg As FileDialog, Dic As Object Dim Pfad$, Datei$, Rw&, Sp&, Idx$ Application.ScreenUpdating = False With Application.FileDialog(msoFileDialogFolderPicker) .Title = "Bitte Bilder-Pfad wählen" .AllowMultiSelect = False If .Show -1 Then MsgBox "Vorgang abgebrochen", vbInformation Exit Sub Else: Pfad = .SelectedItems(1) & "\" End If End With Set Dic = CreateObject("Scripting.Dictionary") Datei = Dir(Pfad & "*.*", vbNormal) With Ws Do While Datei "" If LCase(Right(Datei, 3)) = "jpg" Or LCase(Right(Datei, 3)) = _ "png" Then Idx = Left(Datei, InStr(1, Datei, ".") - 1) Rw = .Cells(.Rows.Count, 8).End(xlUp).Offset(1, 0).Row 'Hauptdatei If InStrRev(Datei, ".", Len(Datei) - 4) = 0 Then If Not Dic.exists(Idx) Then Dic.Add Idx, Rw .Cells(Rw, 8) = Datei .Cells(.Rows.Count, 6).End(xlUp).Offset(1, 0) = Datei Else: .Cells(Dic(Idx), 8) = Datei .Cells(.Rows.Count, 6).End(xlUp).Offset(1, 0) = Datei End If 'Folgedatei bis #10 Else: Sp = CLng(Mid(Datei, InStr(1, Datei, ".") + 1, 2)) If Sp

Sub a() Dim Wb As Workbook: Set Wb = ThisWorkbook Dim Ws As Worksheet: Set Ws = Wb.Worksheets("Beispiel") Dim Dlg As FileDialog, Dic As Object Dim Pfad$, Datei$, Rw&, Sp&, Idx$ Application.ScreenUpdating = False Pfad = IIf(Right(Ws.Range("C2"), 1) = "\", Ws.Range("C2"), _ Ws.Range("C2") & "\") Set Dic = CreateObject("Scripting.Dictionary") Datei = Dir(Pfad & "*.*", vbNormal) With Ws Do While Datei "" If LCase(Right(Datei, 3)) = "jpg" Or LCase(Right(Datei, 3)) = _ "png" Then Idx = Left(Datei, InStr(1, Datei, ".") - 1) Rw = .Cells(.Rows.Count, 8).End(xlUp).Offset(1, 0).Row 'Hauptdatei If InStrRev(Datei, ".", Len(Datei) - 4) = 0 Then If Not Dic.exists(Idx) Then Dic.Add Idx, Rw .Cells(Rw, 8) = Datei .Cells(.Rows.Count, 6).End(xlUp).Offset(1, 0) = Datei Else: .Cells(Dic(Idx), 8) = Datei .Cells(.Rows.Count, 6).End(xlUp).Offset(1, 0) = Datei End If 'Folgedatei bis #10 Else: Sp = CLng(Mid(Datei, InStr(1, Datei, ".") + 1, 2)) If Sp

Hallo,
es tut mir sehr leid das ich da nicht hin bekomme!
kann es sein das hier (Fett Markiert) etwas nicht stimmt?
Sub a()
Dim Wb As Workbook: Set Wb = ThisWorkbook
Dim Ws As Worksheet: Set Ws = Wb.Worksheets("Beispiel")
Dim Dlg As FileDialog, Dic As Object
Dim Pfad$, Datei$, Rw&, Sp&, Idx$
Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte Bilder-Pfad wählen"
.AllowMultiSelect = False
If .Show -1 Then
MsgBox "Vorgang abgebrochen", vbInformation
Exit Sub
Else: Pfad = .SelectedItems(1) & "\"
End If
End With
Set Dic = CreateObject("Scripting.Dictionary")
Datei = Dir(Pfad & "*.*", vbNormal)
With Ws
Do While Datei ""
If LCase(Right(Datei, 3)) = "jpg" Or LCase(Right(Datei, 3)) = _
"png" Then
Idx = Left(Datei, InStr(1, Datei, ".") - 1)
Rw = .Cells(.Rows.Count, 8).End(xlUp).Offset(1, 0).Row
'Hauptdatei
If InStrRev(Datei, ".", Len(Datei) - 4) = 0 Then
If Not Dic.exists(Idx) Then
Dic.Add Idx, Rw
.Cells(Rw, 8) = Datei
.Cells(.Rows.Count, 6).End(xlUp).Offset(1, 0) = Datei
Else:
.Cells(Dic(Idx), 8) = Datei
.Cells(.Rows.Count, 6).End(xlUp).Offset(1, 0) = Datei
End If
'Folgedatei bis #10
Else:
Sp = CLng(Mid(Datei, InStr(1, Datei, ".") + 1, 2))
Gäbe es die Möglichkeit das ich einfach deine Liste runterlade? (die in der das Makro läuft)
Danke für die Geduld echt!
Und doch ich Arbeite unter Windows.

Beliebteste Forumthreads (12 Monate)

Bilder in einem Ordner auslesen und sortieren

17
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

305 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Bilder in einem Ordner auslesen und sortieren

17 Beiträge zum Forumthread Beiträge zu diesem Forumthread

305 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

17
Beiträge zum Forumthread

Beiträge zu diesem Forumthread