Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1640to1644
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Ordner durchsuchen, einschl. Unterordner

Ordner durchsuchen, einschl. Unterordner
04.09.2018 07:04:01
Hajo_Zi
Hallo,
es geht um Version 2016, die nicht ausgewählt werden kann.
Ich glaube dies muss über eine Funktion gelöst werden.
Ich habe einen Dateinamen z.B. 140E5111
Diese Datei mus in einem Ordner einschl. Unterordner gesucht werden.
Hinter den Dateinamen muss aber [1] stehen. Wobei ich die höchste Zahl benötige.
Es darf keine Datei mit einem Zusatz gesucht werden z.B. "BAK_140E5111"
Es sollen folgende Dateitypen gesucht werden
- PDF
- SLDPRT
- DXF
- Steep
Der Funktion würde ich den Dateinamen und den Dateityp übergeben.
Ich benötige den Ablageort einschl. dem kompletten Dateinamen.
Gruß Hajo

32
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: snb - Code
04.09.2018 10:15:43
Fennek
Hallo Hajo,
für diese Augabe empfiehlt snb folgenden Code:

Sub M_snb_dir()
Dim s$, a, d
' hier mit Schalter /s für Unterverzeichnisse
s = ASCIItoANSI(CreateObject("wscript.shell"). _
exec("cmd /c dir ""c:\temp\*.xls*"" /s/b/od") _
.stdout.readall)
a = Split(s, vbCrLf)
Debug.Print UBound(a) ' bei -1 war der String leer
For Each d In a
Debug.Print d
Next d
End Sub
Auch wenn Ordner- oder Dateinamen Umlaute bzw Leerzeichen enthalten, sollte der Code in dierser Variante gehen. Ein 1-dim Array zu filtern, brauche ich nicht zu erklären.
mfg
Anzeige
AW: sorry: Zusatz
04.09.2018 10:17:40
Fennek

Private Declare Function OemToCharA Lib "user32.dll" _
(ByVal lpszSrc As String, ByVal lpszDst As String) As Long
Public Function ASCIItoANSI(ByVal Text As String) As String
Call OemToCharA(Text, Text)
ASCIItoANSI = Text
End Function

AW: sorry: Zusatz
04.09.2018 10:38:24
Hajo_Zi
Hallo,
die erste Zeile
"Private Declare Function OemToCharA…"
ist Rot, muss ich noch einen Verweis setzen?
Im ersten Code sehen ich nicht die Suche nach [Version Nummer]
Die Version Nummer ist nicht bekannt.
Gruß Hajo
AW: Nö, FIlter
04.09.2018 10:46:19
Fennek
Hallo Hajo,
der Code stammt aus dem Archiv, sollte aber so gelaufen sein (xl 2016, Win 8.1)
Es wird eine Serie von Filtern nötig, z.B.

s1 = filter(sn, "[")

Anzeige
AW: Nö, FIlter
04.09.2018 10:54:08
Hajo_Zi
Kopiere den gesamten vorgeschlagenen Code in ein Modul. Es dürfte bei Dir auch die erste Zeile rot sein.
Es ist eine 32 Bit Anwendung.
mit
"s1 = filter(sn, "[")"
kann ich nichts anfangen.
Gruß Hajo
AW: getestet
04.09.2018 11:11:20
Fennek
Pfad und Extension müssen angepasst werden:

Private Declare Function OemToCharA Lib "user32.dll" _
(ByVal lpszSrc As String, ByVal lpszDst As String) As Long
Public Function ASCIItoANSI(ByVal Text As String) As String
Call OemToCharA(Text, Text)
ASCIItoANSI = Text
End Function
Sub M_snb_dir()
' hier mit Schalter /s für Unterverzeichnisse
fn = Filter(Split(ASCIItoANSI(CreateObject("wscript.shell"). _
exec("cmd /c dir ""c:\temp\*.xls*"" /s/b/od") _
.stdout.readall), vbCrLf), "[", True)
PDF = Filter(fn, "PDF")
SLDPRT = Filter(fn, "SLDPRT")
DXF = Filter(fn, "DXF")
Steep = Filter(fn, "Steep")
Debug.Print Join(fn, vbCrLf)
Debug.Print Join(PDF, vbCrLf)
End Sub
mfg
Anzeige
AW: getestet
04.09.2018 11:17:24
Hajo_Zi
die erste Zeile ist immer noch rot.
Gruß Hajo
AW: ohne Zeilenumbruch? (owT)
04.09.2018 11:27:28
Fennek
hatte es schon entfernt oT
04.09.2018 11:29:06
Hajo_Zi
AW: mehr als testen geht nicht (kT)
04.09.2018 11:33:00
Fennek
AW: Vieleicht Datei?
04.09.2018 11:35:39
Hajo_Zi
Vielleicht mal Deine Datei hochladen, in der es nicht rot ist.
Ich vermute Du hast einen Verweis gesetzt, den ich nicht habe.
Gruß Hajo
AW: kein Verweis!
04.09.2018 11:49:40
Fennek
Hallo,
nach meinem (eher geringen) Verständnis werden für API's keine Verweise gesetzt. Die UserDll ist Standard.
Also keine Ahnung!
mfg
(von der Datei habe ich nur den Code aufgehoben, die API gehört an den Anfang einen allgemeinen Moduls)
AW: kein Verweis!
04.09.2018 12:00:28
Hajo_Zi
gut das hatte ich gemacht.
Gruß Hajo
AW: kein Verweis!
04.09.2018 12:03:46
PeterK
Hallo
Versuch mal:

#If VBA7 Then
Private Declare PtrSafe Function OemToCharA Lib "user32.dll" _
(ByVal lpszSrc As String, ByVal lpszDst As String) As Long
#Else
Private Declare PtrSafe Function OemToCharA Lib "user32.dll" _
(ByVal lpszSrc As String, ByVal lpszDst As String) As Long
#End If

Anzeige
AW: kein Verweis!
04.09.2018 12:18:15
Hajo_Zi
es ist nicht mehr rot.
Es Kommt aber ein schwarzes Fenster. Das mit X geschlossen werden muss.
bei
Call OemToCharA(Text, Text)
Ist Text =""
Gruß Hajo
AW: kein Verweis!
04.09.2018 12:22:21
Hajo_Zi
die Zeile mit Dateinamen habe ich geändert auf
fn = Filter(Split(ASCIItoANSI(CreateObject("wscript.shell"). _
exec("cmd /c dir ""\\BMS....\...\3001-E461-1759*.pdf"" /s/b/od") _
.stdout.readall), vbCrLf), "[", True)
Gruß Hajo
AW: snb - Code
04.09.2018 17:03:17
Nepumuk
Hallo Fennek,
diese Art Dateien aus Verzeichnissen auszulesen hat Anton schon vor über 10 Jahren gepostet, da ging snb noch in den Kindergarten.
Gruß
Nepumuk
AW: Warum geht es bei Hajo nicht? (owT)
05.09.2018 10:52:39
Fennek
AW: Warum geht es bei Hajo nicht? (owT)
05.09.2018 14:42:35
Nepumuk
Hallo Fennek,
keine Ahnung. Ich schau nicht auf fremde Rechner, soll er doch einen fragen der neben ihm sitzt.
Gruß
Nepumuk
Anzeige
AW: Ordner durchsuchen, einschl. Unterordner
04.09.2018 13:24:54
PeterK
Hallo
Ein anderer Ansatz
Das Makro gibt Dir alle Dateien (inklusive Unterordner) aus.

Sub MyMain()
Const myPath = "C:\Users\"
Dim fso As Object
Dim startFolder As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set startFolder = fso.getfolder(myPath)
If startFolder Is Nothing Then
Debug.Print "Folder " & myPath & " does'nt exist ..."
Else
Call GetFiles(startFolder)
End If
End Sub
Sub GetFiles(folder As Object)
Dim subFolder As Object
Dim allFiles As Object
Dim myFile As Object
For Each subFolder In folder.subfolders
Call GetFiles(subFolder)
Next
Set allFiles = folder.Files
For Each myFile In allFiles
'hier muss der Dateiname auf Gültigkeit geprüft werden'
Debug.Print myFile.Path, myFile.Name, myFile.Type
Next
End Sub

Anzeige
AW: Ordner durchsuchen, einschl. Unterordner
04.09.2018 13:57:46
Hajo_Zi
das ist der falsche Ansatz, ich brauche den Filter auf Dateiname, Typ und Version.
Gruß Hajo
AW: Ordner durchsuchen, einschl. Unterordner
04.09.2018 15:02:06
PeterK
Hallo
Code mit Filterkriterien

Sub MyMain()
Const myPath = "C:\Users\Downloads\"
Const myName = "3662555379"
Const myType = "pdf"
Dim fso As Object
Dim startFolder As Object
Dim foundFile As String
Dim foundVersion As Long
Set fso = CreateObject("Scripting.FileSystemObject")
Set startFolder = fso.getfolder(myPath)
If startFolder Is Nothing Then
Debug.Print "Folder " & myPath & " does'nt exist ..."
Else
foundFile = ""
foundVersion = 0
Call GetFiles(startFolder, myName, myType, foundFile, foundVersion)
Debug.Print foundFile
End If
End Sub
Sub GetFiles(folder As Object, seaName As String, seaType As String, foundFile As String,  _
foundVersion As Long)
Dim subFolder As Object
Dim allFiles As Object
Dim myFile As Object
Dim splitArray() As String
Dim myVersion As Long
For Each subFolder In folder.subfolders
Call GetFiles(subFolder, seaName, seaType, foundFile, foundVersion)
Next
Set allFiles = folder.Files
For Each myFile In allFiles
splitArray = Split(myFile.Name, ".")   ' hier wird Dateiname/Dateityp getrennt
If UCase(splitArray(UBound(splitArray))) = UCase(seaType) Then
' wir haben den richtigen Dateityp
If UCase(seaName) = Mid(UCase(splitArray(LBound(splitArray))), 1, Len(seaName)) Then
' wir haben den richtigen Dateinamen und ermitteln die Version
splitArray = Split(myFile.Name, "[")
If UBound(splitArray) > 0 Then
splitArray = Split(splitArray(UBound(splitArray)), "]")
myVersion = CInt(splitArray(LBound(splitArray)))
If myVersion > foundVersion Then
foundVersion = myVersion
foundFile = myFile.Path
End If
End If
End If
End If
Next
End Sub

Anzeige
AW: Ordner durchsuchen, einschl. Unterordner
04.09.2018 14:26:32
Daniel
Hi
geht in allen Versionen, sollte sich auch einfach in eine Funktion umschreiben lassen:
Sub DateiSuche()
'Spezial;Dateien suchen
Dim StartPfad As String
Dim Pfade() As String
Dim SuchDatei As String
Dim SuchTyp As String
Dim Dateien() As String
Dim Datei As String
Dim Pos1 As Long, Pos2 As Long, x As Long
Dim Mx As Long
Dim Erg As String
Dim txt As String
Dim D
'--- Startpfad und Suchstring eingeben
StartPfad = "C:\Daten\"
SuchDatei = "140E5111[*]*"
SuchTyp = "PDF,SLDPRT,DXF,STEEP"
If Right(StartPfad, 1)  "\" Then StartPfad = StartPfad & "\"
If Dir(Left(StartPfad, Len(StartPfad) - 1), vbDirectory) = "" Then MsgBox "Startpfad nicht  _
vorhanden": Exit Sub
'--- Unterpfade ermitteln, Datei suchen -----------
ReDim Pfade(0)
ReDim Dateien(0)
Pfade(0) = StartPfad
Pos1 = 0
Pos2 = UBound(Pfade)
Do
For x = Pos1 To Pos2
Datei = Dir(Pfade(x), vbDirectory)
Do While Datei Like ".*"
Datei = Dir
Loop
Do While Datei  ""
If Len(Pfade(x) & Datei)  0 Then
Dateien(UBound(Dateien)) = Pfade(x) & Datei
ReDim Preserve Dateien(UBound(Dateien) + 1)
End If
Case Else
End Select
End If
Datei = Dir
Loop
Next
Pos1 = Pos2 + 1
Pos2 = UBound(Pfade)
Loop While Pos1  0 Then
For Each D In Dateien
If D  "" Then
txt = Mid(D, InStr(D, "[") + 1)
txt = Left(txt, InStr(txt, "]") - 1)
If Val(txt) > Mx Then
Mx = Val(txt)
Erg = D
End If
End If
Next
End If
MsgBox Erg
End Sub

nicht getestet
Gruß Daniel
Anzeige
AW: Ordner durchsuchen, einschl. Unterordner
04.09.2018 16:21:07
Hajo_Zi
Hallo Daniel,
ich bin schon zu Hause. Morgen Früh werde ich es im Betrieb testen.
Gruß Hajo
AW: Ordner durchsuchen, einschl. Unterordner
05.09.2018 06:30:05
Hajo_Zi
Hallo Daniel,
vor case Else fehlte ein End If.
Ich habe
StartPfad = "\\BMS...\….\"
geschrieben.
Kopiere ich den Pfad in den Windows Explorer, wird er gefunden.
Das Makro meine nicht vorhanden?
Gruß Hajo
AW: Ordner durchsuchen, einschl. Unterordner
05.09.2018 10:58:45
Daniel
Hi
dann teste erstmal, ob das Makro grundsätzlich funktioniert und kopiere hierzu die Dateien in ein "normales" Verzeichnis ("C:\...")
Gruß Daniel
AW: Ordner durchsuchen, einschl. Unterordner
05.09.2018 13:34:27
Hajo_Zi
Hallo Daniel,
das Programm ist nicht für meinen Arbeitsbereich. Ich habe überhaupt keine Ahnung was da für eine Ordner Struktur besteht.
Ich mache dies Programm auch nur neben bei, für das kopieren brauche ich dann mehr Zeit, keine Ahnung wann ich dazu Zeit habe.
Mit Peter seiner Änderung liefe es durch aber mit Laufzeitfehler, siehe Beitrag bei Peter.
Was mir aber stört ist die Zeit.
Wir haben jetzt schon ein Programmpaket, das liest aber nicht alle Dateien aus, darum wollte ich ein neues machen. Dieses Programmpaket darf ich nicht veröffentlichen, da zu viele Betriebsdaten drin sind.
Gruß Hajo
Anzeige
AW: Ordner durchsuchen, einschl. Unterordner
05.09.2018 12:54:26
PeterK
Hallo
Das Netzwerklaufwerk fordert das abschliessende "\". Bitte Makro folgendermassen ändern:
Statt: If Dir(Left(StartPfad, Len(StartPfad) - 1), vbDirectory) = ...
If Dir(StartPfad, vbDirectory) = ...
AW: Ordner durchsuchen, einschl. Unterordner
05.09.2018 13:28:10
Hajo_Zi
Hallo Peter,
damit läuft der Code durch, aber es dauert ewig.
Irgend wann kommt Debugger 53 "Datei nicht gefunden" in der Zeile
Select Case GetAttr(Pfade(x) & Datei)
Datei ist "Prevodovky - DE (2009).pdf"
Pfade(x) ist \\BMS...\...\...\...\...\
Gruß Hajo
AW: Ordner durchsuchen, einschl. Unterordner
05.09.2018 14:59:16
PeterK
Hallo
Ich bin mir sicher, das diese Datei ein Sonderzeichen z.B. "ý" enthält
AW: Warum geht der Code bei Hajo nicht?
05.09.2018 12:08:39
Fennek
Hallo,
der Code stammt aus der DOS-Welt und ist für Pfad- und Dateinamen jeseits der DOS-Konventionen erweitert.
Meistens vereinfacht diese Art die Programmierung deutlich, deshalb die bisher ungeklärte Frage, was an Hajo's System die Ausführung verhindert?
mfg
weil Hajo schwarzes Fenster schließt ;-) oT
05.09.2018 18:11:39
Anton

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige