Datei suchen und auflisten

[Andyle]

Hallo an alle.

ich habe folgenden Code:

Code:

Sub Dateien(Objekt As Object)
Dim Item As Object

For Each Item In Objekt

If Range("D7") <> "" And Range("D9") <> "" Then

' UCase(Range("D8")) bedeutet Umwandlung der endung auf Großbuchstaben
If InStrRev(Range("D7") & Range("D9"), Range("D9")) > 0 Or InStrRev(Range("D7") & Range("D9"), UCase(Range("D9"))) > 0 Then

If Item.Name = Range("D7") & Range("D9") Or Item.Name = Range("D7") & UCase(Range("D9")) Then

'If Item.Name = "*" & Range("D7") & "*" & Range("D9") Or Item.Name = "*" & Range("D7") & "*" & UCase(Range("D9")) Then


   
    [a65536].End(xlUp).Offset(1, 0) = "=HYPERLINK(" & _
                    """" & Item.Path & """," & _
                    """" & Range("D7") & Range("D9") & """)"
                   
                    lRowCounter = lRowCounter + 1
                   
                    End If
                   
                    End If
                   
Else


If InStrRev(Item.Name, Range("D9")) > 0 Or InStrRev(Item.Name, UCase(Range("D9"))) > 0 Then
   
    [a65536].End(xlUp).Offset(1, 0) = "=HYPERLINK(" & _
                    """" & Item.Path & """," & _
                    """" & Item.Name & """)"
                   
                    lRowCounter = lRowCounter + 1
                   
End If

End If
                   
Next

End Sub

Wie kann ich nach einem Dateinamen Range("D7") im Form von 20240101* suchen wenn der 
Dateiname "20240101 Testfirma Angebot Pumpe.pdf" lautet? 

Besser wäre natürlich nach einem Wortstück zu suchen: Suche nach: Testfirma im Dateinamen "20240101 Testfirma Angebot Pumpe.pdf"

(Leerzeichen könnten generell im Dateinamen auftauchen)

Vielen dank

[schauan]

Hallöchen,

dazu gibt es den Dir-Befehl.

MeineDatei = Dir("*...*")

können mehrere Treffer auftreten? Dann erzeuge ein Array mit den Treffern - hier mal ein Ansatz. Das Array für die Dateien habe ich hier mal mit 1000 vorbelegt.

Code:

Sub DateiListe()
Dim arrDateien, iCnt%
'Array für 1000 Dateien - sollte groesser sein als die zu erwartende Dateianzahl, ansonsten kommt ein Fehler
ReDim arrDateien(1000)
'erste Datei aufgreifen
MeineDatei = Dir("C:\Temp\*.*")
'Schleife ueber alle entsprechenden Dateien
While MeineDatei <> ""
  'Treffer in Array aufehmen
  arrDateien(iCnt) = MeineDatei
  'naechste Datei aufgreifen
  MeineDatei = Dir
  'Array-Index hochzählen
  iCnt = iCnt + 1
'Ende Schleife ueber alle entsprechenden Dateien
Wend
'Arraygroesse auf Anzahl Treffer zuruecksetzen
ReDim Preserve arrDateien(iCnt - 1)
End Sub

[Andyle]

Vieleicht habe ich mich etwas unverständlich ausgedrückt!

D7 da möchte ich ein Wortteil aus einem Dateinamen suchen
D9 steht die Dateiendung zur Auswahl (.jpg, .pdf usw.)

Es sollen alle Dateien aufgelistet werden, wo der gesuchte Wortteil aus D7 vorkommt.

Mein Code findet momentan nur die exakte Übereinstimmung des Dateinamens. Möchte aber nur Wortteile eingeben und in Dateinamen suchen und auflisten.

[schauan]

Kannst Du Range("D7") nicht in das Beispiel einbauen?

[Andyle]

sicher, nur mein Verzeichnisbaum sieht wie folgt aus:

Hauptordner C:\Test

Dateien im Hauptordner
Test1.pdf
Unterordner: -> Angebote
Test2.pdf
Test3.pdf
Unterordner: -> Belege
Test4.pdf
Unterordner: -> Rechnungen
Test5.pdf
Test6.pdf

Über D7 soll er zB. bei Eingabe "4" die Auflistung wie folgt bringen:

Hauptordner C:\Test

Dateien im Hauptordner

Unterordner: -> Angebote
Unterordner: -> Belege
Test4.pdf
Unterordner: -> Rechnungen

[schauan]

Hallöchen,

1)
Kannst Du Range("D7") nicht in das Beispiel einbauen?
Die Frage ist noch unbeantwortet oder meinst Du mit "sicher", dass das klappt?

2)
wenn das klappt, dann schauen wir, wie das mit den Unterordner geht. Stand übrigens nix davon in der ursprünglichen Aufgabe ...
Da ergibt sich die nächste Frage - sind alle Unterordner zu durchsuchen oder gibt es nur bestimmte ...
bei bestimmten könntest Du die Ordner fest einbinden und z.B. Schleife für diese Ordner wiederholen.

[Andyle]

Hier der komplette Code:

Code:

Option Explicit
Public lRowCounter As Long
Public Ordnercount As Long

Sub Auslesen1()

Dim objShell As Object
Dim objFolder As Object
Dim x As Object
Dim y As Object

lRowCounter = 0
Ordnercount = 0

Range("D4") = ""
Range("D5") = ""

If Range("A1") <> "" Then
Call del_b
End If

  Set objShell = CreateObject("Shell.Application")
  With objShell
  If Range("D11") = "" Then
    Set objFolder = .BrowseForFolder(0&, "Pfad", 0, "" & Range("D1") & "")
    Else
    Set objFolder = .BrowseForFolder(0&, "Pfad", 0, "" & Range("D1") & Range("D11") & "\")
    End If
  End With

Set x = CreateObject("Scripting.FileSystemObject")

If (Not objFolder Is Nothing) Then
Set y = x.getfolder(objFolder.self.Path)

Else
  Exit Sub
  End If
'Set y = x.GetFolder(ActiveWorkbook.Path)


[a1] = "HAUPTORDNER: " & y.Path
[a1].Interior.Color = vbBlue
[a1].Font.Color = RGB(255, 255, 255)
Dateien y.Files
Ordner y


If Range("D9") <> "" Then

If lRowCounter = 0 Then
Range("D5") = "Es wurden keine Dateien gefunden!"
ElseIf lRowCounter = 1 Then
Range("D5") = "Es wurde " & lRowCounter & " Dateie gefunden!"
Else
Range("D5") = "Es wurden " & lRowCounter & " Dateien gefunden!"
End If

If lRowCounter = 0 Then
MsgBox "Es wurden keine Dateien mit der Endung " & """" & Range("D9") & """" & " gefunden!"
ElseIf lRowCounter = 1 Then
MsgBox "Es wurde " & lRowCounter & " Datei mit der Endung " & """" & Range("D9") & """" & " gefunden!"
Else
MsgBox "Es wurden " & lRowCounter & " Dateien mit der Endung " & """" & Range("D9") & """" & " gefunden!"
End If

Else

Range("D5") = lRowCounter

If lRowCounter = 0 Then
MsgBox "Es wurden keine Dateien gefunden!"
ElseIf lRowCounter = 1 Then
MsgBox "Es wurde " & lRowCounter & " Datei gefunden!"
Else
MsgBox "Es wurden " & lRowCounter & " Dateien gefunden!"
End If

End If

If Ordnercount > 0 Then
Range("D4") = "Es wurden " & Ordnercount & " Unterordner gefunden!"
End If

'------------------
' Unterordner auslesen und in Spalte I auflisten
On Error Resume Next

If Range("I2") <> "" Then
Call del_b
End If

Dim lRow As Long

Dim oFolder As Object, oSFolder As Object, oFS As Object
Set oFS = CreateObject("Scripting.filesystemobject")
Set oFolder = oFS.getfolder(Range("D1").Value) '("C:\Users\Andreas\Documents\Test\")
For Each oSFolder In oFolder.subfolders
ActiveSheet.Cells(Rows.Count, 9).End(xlUp).Offset(1) = oSFolder.Name
Next

lRow = ActiveSheet.Cells(Rows.Count, 9).End(xlUp).Row
ActiveWorkbook.Names.Add Name:="Ordnername", RefersToR1C1:="=Dateiablage!R2C9:R" & lRow & "C9" ' =Dateiablage!I2:I" & lRow

'Sheets("Ordner").Visible = False
ActiveSheet.Range("D10").Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=Ordnername"
'------------------

Range("A1").Select

End Sub

Sub Dateien(Objekt As Object)
Dim Item As Object

For Each Item In Objekt

If Range("D7") <> "" And Range("D9") <> "" Then

' UCase(Range("D8")) bedeutet Umwandlung der endung auf Großbuchstaben
If InStrRev(Range("D7") & Range("D9"), Range("D9")) > 0 Or InStrRev(Range("D7") & Range("D9"), UCase(Range("D9"))) > 0 Then

If Item.Name = Range("D7") & Range("D9") Or Item.Name = Range("D7") & UCase(Range("D9")) Then

'If Item.Name = "*" & Range("D7") & "*" & Range("D9") Or Item.Name = "*" & Range("D7") & "*" & UCase(Range("D9")) Then


   
    [a65536].End(xlUp).Offset(1, 0) = "=HYPERLINK(" & _
                    """" & Item.Path & """," & _
                    """" & Range("D7") & Range("D9") & """)"
                   
                    lRowCounter = lRowCounter + 1
                   
                    End If
                   
                    End If
                   
Else


If InStrRev(Item.Name, Range("D9")) > 0 Or InStrRev(Item.Name, UCase(Range("D9"))) > 0 Then
   
    [a65536].End(xlUp).Offset(1, 0) = "=HYPERLINK(" & _
                    """" & Item.Path & """," & _
                    """" & Item.Name & """)"
                   
                    lRowCounter = lRowCounter + 1
                   
End If

End If
                   
Next

End Sub

Sub Ordner(Objekt As Object)
Dim Ordnername$, Ordnername2$
Dim Item As Object
For Each Item In Objekt.subfolders
    [a65536].End(xlUp).Offset(1, 0) = "Unterordner: -> " & Item.Name
    [a65536].End(xlUp).Font.Color = RGB(0, 0, 0)
    [a65536].End(xlUp).Font.Bold = True
'    [a65536].End(xlUp).Interior.Color = RGB(50, 250, 0)
    Dateien Item.Files
    Ordner Item
   
    Ordnercount = Ordnercount + 1
   
Next
End Sub


Sub del_a()
' del_a Makro
' löscht spalte a

    Columns("A:A").Select
    Selection.ClearContents
    Selection.ClearFormats
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("D4") = ""
    Range("D5") = ""
    Range("D7") = ""
    Range("D8") = ""
    Range("D9") = ""
    Range("D11") = ""
    Range("A1").Select
   
        '-------------
ActiveSheet.Columns("I:I").Select
    Selection.ClearContents
    Selection.ClearFormats
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    ActiveSheet.Range("I2").Select
    ActiveSheet.Range("I1") = "Ordnerliste"
    ActiveSheet.Range("I1").Font.Bold = True
    '---------------

Range("A1").Select
End Sub

Sub del_b()
' del_a Makro
' löscht spalte a

    Columns("A:A").Select
    Selection.ClearContents
    Selection.ClearFormats
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("A1").Select
   
    '-------------
ActiveSheet.Columns("I:I").Select
    Selection.ClearContents
    Selection.ClearFormats
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    ActiveSheet.Range("I2").Select
    ActiveSheet.Range("I1") = "Ordnerliste"
    ActiveSheet.Range("I1").Font.Bold = True
    '---------------

Range("A1").Select
End Sub

[schauan]

Hallöchen,

ich denke, in der Zeile

If Item.Name = Range("D7") & Range("D9") Or Item.Name = Range("D7") & UCase(Range("D9")) Then

nimmst Du etwas in der Art

If Item.Name Like "*" & Range("D7") & "*" & Range("D9") Or Item.Name Like "*" & Range("D7") & "*"  & UCase(Range("D9")) Then

Wobei Du gleich

If Item.Name Like "*" & Range("D7") & "*"  & UCase(Range("D9")) Then

nehmen kannst ...

[Andyle]

Supi, hat geklappt!

Nur würde ich gern folgenden code erweitern

Bsp:

Ordner
Unterordner
Ordner
Unterordner
Unterordner

Er soll erkennen, ob es ein Hauptordner oder unterordner ist und anzeigen.

Code:

Sub Ordner(Objekt As Object)
Dim Ordnername$, Ordnername2$
Dim Item As Object

For Each Item In Objekt.subfolders
    [a65536].End(xlUp).Offset(1, 0) = "Unterordner: -> " & Item.Name
    [a65536].End(xlUp).Font.Color = RGB(0, 0, 0)
    [a65536].End(xlUp).Font.Bold = True
'    [a65536].End(xlUp).Interior.Color = RGB(50, 250, 0)
    Dateien Item.Files
    Ordner Item
   
    Ordnercount = Ordnercount + 1
   
   
Next
End Sub

[Andyle]

Habe gerade bemerkt, dass exakt nach Groß- Kleinschreibung gesucht wird.

Kann man es anpassen, das diese egal ist?

Danke

Groß- Kleinschreibung  erledigt!