Registriert seit: 01.07.2023
Version(en): Pro Plus 2019
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
Registriert seit: 10.04.2014
Version(en): 97-2019 (32) + 365 (64)
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
. \\\|/// Hoffe, geholfen zu haben.
( ô ô ) Grüße, André aus G in T
ooO-(_)-Ooo (Excel 97-2019+365)
Registriert seit: 01.07.2023
Version(en): Pro Plus 2019
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.
Registriert seit: 10.04.2014
Version(en): 97-2019 (32) + 365 (64)
Kannst Du Range("D7") nicht in das Beispiel einbauen?
. \\\|/// Hoffe, geholfen zu haben.
( ô ô ) Grüße, André aus G in T
ooO-(_)-Ooo (Excel 97-2019+365)
Registriert seit: 01.07.2023
Version(en): Pro Plus 2019
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
Registriert seit: 10.04.2014
Version(en): 97-2019 (32) + 365 (64)
21.04.2024, 10:25
(Dieser Beitrag wurde zuletzt bearbeitet: 21.04.2024, 10:28 von 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.
. \\\|/// Hoffe, geholfen zu haben.
( ô ô ) Grüße, André aus G in T
ooO-(_)-Ooo (Excel 97-2019+365)
Registriert seit: 01.07.2023
Version(en): Pro Plus 2019
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
Registriert seit: 10.04.2014
Version(en): 97-2019 (32) + 365 (64)
21.04.2024, 11:35
(Dieser Beitrag wurde zuletzt bearbeitet: 21.04.2024, 11:36 von 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 ...
. \\\|/// Hoffe, geholfen zu haben.
( ô ô ) Grüße, André aus G in T
ooO-(_)-Ooo (Excel 97-2019+365)
Registriert seit: 01.07.2023
Version(en): Pro Plus 2019
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
Registriert seit: 01.07.2023
Version(en): Pro Plus 2019
21.04.2024, 17:37
(Dieser Beitrag wurde zuletzt bearbeitet: 21.04.2024, 17:37 von Andyle.)
Habe gerade bemerkt, dass exakt nach Groß- Kleinschreibung gesucht wird.
Kann man es anpassen, das diese egal ist?
Danke
Groß- Kleinschreibung erledigt!
|
