Ordner und Unterordner nach JPG auslesen

[Karlheinz16]

Hallo EXCEL-Spezialisten,
ich habe mit einer Software,  die Bilder vom Handy auf den PC übertragen. Das sieht dann z.B. so aus:
J:\Neuer Ordner
darin sind viele Ordner deren Namen das Aufnahme-Datum ist. Manchmal ist in einem Datums-Ordner eine JPG-Datei oder auch mal 10, ganz verschieden. 
Nun suche ich einen VBA-Code, der den Ordner "Neuer Ordner" und alle Datums-Ordner nach JPG durchsucht und im Blatt "Bilder" Spalte "A" auflistet. Ich habe hier im Forum einen Code gefunden, der eigentlich super funktioniert, aber keine Unterordner durchsucht.

Code:

Sub Bilder()
Dim lngZeile As Long
Dim objFileSystem As Object
Dim objVerzeichnis As Object
Dim objDateienliste As Object
Dim objDatei As Object

Dim t As Double
t = Timer


With Worksheets("Bilder")
    Sheets("Bilder").Select
ActiveSheet.Unprotect

Range("A3:A7000").ClearContents
    Range("A3").Select
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

Set objFileSystem = CreateObject("scripting.FileSystemObject")
Set objVerzeichnis = objFileSystem.GetFolder("J:\Neuer Ordner\")
Set objDateienliste = objVerzeichnis.Files

lngZeile = 3 'ab welche Zeile wird eingetragen

For Each objDatei In objDateienliste
   
    If Not objDatei Is Nothing And Right(LCase(objDatei.Name), 4) = ".jpg" Then
     
          ActiveSheet.Cells(lngZeile, 1) = objDatei.Name 'in welche Spalte wird eingetragen
          lngZeile = lngZeile + 1
     End If

Next objDatei
End With
ActiveSheet.Protect

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

MsgBox Timer - t & " sec", , "Makrolaufzeit"

End Sub

Wenn der Ordner JPG enthält, funktioniert dieser Code wunderbar, doch bei mir ist im Ordner "Neuer Ordner" keine einzige JPG-Datei, alles nur in den Datums-Ordnern, deshalb funktioniert dieser Code jetzt nicht.
Gibt es eine Möglichkeit, das zu ändern?

Vielen Dank für eure Hilfe, wenn noch Fragen offen sind, stehe ich gerne zur Verfügung.

Viele Grüße

Karlheinz

[volti]

Hallo Karlheinz,

zu später Stunde zunächst einmal ein Tipp:

Vielleicht hilft Dir dies hier schon weiter...

Dateien auflisten incl. aus Unterordnern

Gruß
Karl-Heinz

[Ralf A]

darin sind viele Ordner deren Namen das Aufnahme-Datum ist. Manchmal ist in einem Datums-Ordner eine JPG-Datei oder auch mal 10, ganz verschieden. 
Nun suche ich einen VBA-Code, der den Ordner "Neuer Ordner" und alle Datums-Ordner nach JPG durchsucht und im Blatt "Bilder" Spalte "A" auflistet. Ich habe hier im Forum einen Code gefunden, der eigentlich super funktioniert, aber keine Unterordner durchsucht.

Dazu bedarf es keines aufwendigen VBA Codes, da genügen ein paar Mausklicks. Menü Daten --> Daen abrufen --> Aus Datei --> Aus Ordner __> Datentransformieren, nach Extension filtern, anzuzigende Spalten auswählen --> Laden in...
Und schon hast Du alle Dateien incl. der Dateien aus sämtlichen Unterordnern...

Der M-Code dazu könnte so aussehen:

PHP-Code:

let
    Quelle = Folder.Files("C:\Users\User\OneDrive\Bilder"),
    #"Text in Kleinbuchstaben" = Table.TransformColumns(Quelle,{{"Extension", Text.Lower, type text}}),
    #"Gefilterte Zeilen" = Table.SelectRows(#"Text in Kleinbuchstaben", each ([Extension] = ".jpeg" or [Extension] = ".jpg" or [Extension] = ".png" or [Extension] = ".thumbnail")),
    #"Hinzugefügte benutzerdefinierte Spalte" = Table.AddColumn(#"Gefilterte Zeilen", "Pfad", each [Folder Path] & "\" & [Name]),
    #"Andere entfernte Spalten" = Table.SelectColumns(#"Hinzugefügte benutzerdefinierte Spalte",{"Pfad", "Date created"})
in
    #"Andere entfernte Spalten"


Nur wenn Du daraus automatisch einen Link erstellen willst, dann brauchst Du allerdings doch VBA.... :)

Code:

Sub CreateLinks()
Dim z As Range, rng As Range
Set rng = Tabelle1.ListObjects(1).DataBodyRange.Columns(1)
    For Each z In rng.Rows
        ActiveSheet.Hyperlinks.Add Anchor:=z, Address:=z.Value, TextToDisplay:=z.Value
    Next
Set rng = Nothing
End Sub

[Andreas Killer]

Etwas ausführlicheres Video:
https://www.youtube.com/watch?v=ZiQWdDtbbs4

Andreas.

[schauan]

Hallöchen,

Nur wenn Du daraus automatisch einen Link erstellen willst, dann brauchst Du allerdings doch VBA.... :)

Das ist derzeit die Crux

Du könntest manuell anschließend z.B. in der nächsten Spalte mit einmaliger Eingabe von =HYPERLINK("A2") bzw. =HYPERLINK([@Pfad]) alle restlichen Links automatisch erzeugen und bräuchtest wiederum kein VBA ....

[knobbi38]

Hallo Karl-Heinz,

für solche Aufgaben kannst du folgendes Modul in dein Projekt importieren und dann sehr flexibel mit der Funktion FileSearchINFO() nach *.jpg suchen.
Die Beschreibung zu der Funktion findest du im Modul.

Knobbi38

[snb]

Mein Vorschlag:

Code:

Sub M_snb()
    sn = Split(CreateObject("wscript.shell").exec("cmd /c dir ""G:\Neuer ordner\*.jpg"" /a/s/b").stdout.readall, vbCrLf)
    Cells(1).Resize(UBound(sn) + 1) = Application.Transpose(sn)
End Sub

[slowboarder]

Hi

der folgende Code durchsucht das angegebene Verzeichnis sowie alle Unterverzeichnise und listet die jpg-Dateien:

Code:

Sub JPG_Suchen()
Dim Ordner
Dim i As Long
Dim Datei As String
Dim Zeile As Long

Zeile = 1

ReDim Ordner(0)
Ordner(0) = "J:\Neuer Ordner\"

i = 0
Do Until i > UBound(Ordner)
    Datei = Dir(Ordner(i) & "*", vbDirectory)
    Do Until Datei = ""
        If Datei = "." Or Datei = ".." Then
        ElseIf (GetAttr(Ordner(i) & Datei) And vbDirectory) = vbDirectory Then
            ReDim Preserve Ordner(0 To UBound(Ordner) + 1)
            Ordner(UBound(Ordner)) = Ordner(i) & Datei & "\"
        ElseIf Datei Like "*.jpg" Then
            ActiveSheet.Cells(Zeile, 1) = Ordner(i) & Datei
            Zeile = Zeile + 1
        Else
        End If
        Datei = Dir
    Loop
    i = i + 1
Loop
       
End Sub

das arbeitet mit der einfachen DIR-Funktion. Zusätzliche Anforderungen wie "nur Unterordner mit Datum durchsuchten" sollten sich einfach einbauen lassen.

Gruß Daniel

[knobbi38]

@snb:

Hatten wir doch schon mal. Wenn, dann solltest du auch die Einschränkung mit angeben, daß bei der Kommandzeile nicht alle Zeichen fehlerfrei übernommen werden.

Knobbi38

[Egon12]

Hallo,

da es in der deutschen Sprache Umlaute gibt sollte man wenigstens dafür sorgen, dass falls solche vorhanden sind diese dann mit ausgelesen werden.

Deshalb besser so:

Code:

Option Explicit
    Private Declare PtrSafe Function OemToCharA Lib "user32.dll" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
   
Public Function fncFromDuskTillDawn(ByVal strTMP As String) As String
    Call OemToCharA(strTMP, strTMP)
    fncFromDuskTillDawn = strTMP
End Function

Public Sub neu()  ' gefiltert .jpg ohne Unterverzeichnissen Umlaute korrekt
    Dim arr, Pfad$
    Pfad = "D:\Users"
    arr = Filter(Split(fncFromDuskTillDawn(CreateObject("Wscript.Shell").exec("cmd /c dir """ & Pfad & """ /B /S").stdout.readall), vbCrLf), ".jpg")
    Tabelle1.Cells(1, 1).Resize(UBound(arr), 1) = Application.Transpose(arr)
End Sub

Gruß Uwe