Dateien nur solange durchsuchen bis Ab-Datum erreicht wurde

Option Explicit Private Declare Sub OemToChar Lib "user32" Alias "OemToCharA" (ByVal StrFrom As String, ByVal StrTo As String) Sub listFilesInPath() Dim sPath As String, sFiles() As String, i As Long sPath = "C:\Temp" ' === anpassen! sFiles = getFilesInPath(sPath) For i = LBound(sFiles) To UBound(sFiles) - 1 Debug.Print sFiles(i) Next i End Sub ' Liefert die Dateinamen aller passenden Dateien im angegebenen Pfads als Stringarray in Datumsreihenfolge (älteste Datei zuerst) Private Function getFilesInPath(ByVal sPath As String, Optional ByVal sPattern As String = "*.*") As String() sPath = IIf(Right$(sPath, 1) > Application.PathSeparator, sPath & Application.PathSeparator, sPath) & sPattern getFilesInPath = Split(Ascii2Ansi(CreateObject("wscript.shell").exec("cmd /c dir """ & sPath & """ /b /a:-d /o:-d").StdOut.ReadAll), vbCrLf) End Function ' Wandelt DOS-ASCII-Zeichen zu Windows-ANSI um Private Function Ascii2Ansi(ByVal sAscii As String) As String OemToChar sAscii, sAscii Ascii2Ansi = sAscii End Function

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Private Declare Sub OemToChar Lib "user32" Alias "OemToCharA" (ByVal StrFrom As String, ByVal StrTo As String) Dim colDateien As New Collection Sub listFilesInPath() Dim strDate As String Dim dtDate As Date, dtMaxDate As Date Dim lngDateien As Long, lngZ As Long Dim sPath As String, sFiles() As String, i As Long dtMaxDate = CVDate(ThisWorkbook.Worksheets(1).Range("A1").Value) sPath = "C:\Temp" ' === anpassen! sFiles = getFilesInPath(sPath) For lngZ = LBound(sFiles) To UBound(sFiles) - 1 If sFiles(lngZ) > "" Then strDate = Split(sFiles(lngZ), " ")(0) If IsDate(strDate) Then dtDate = CVDate(strDate) If dtDate = dtMaxDate Then colDateien.Add Trim(Mid$(sFiles(lngZ), 36)) End If End If End If 'Debug.Print sFiles(lngZ) Next lngZ 'Mit Collection arbeiten oder: lngDateien = colDateien.Count If lngDateien > 0 Then ReDim sFiles(colDateien.Count - 1) For lngZ = 1 To lngDateien sFiles(lngZ - 1) = colDateien(lngZ) Next End If End Sub ' Liefert die Dateinamen aller passenden Dateien im angegebenen Pfads als Stringarray in Datumsreihenfolge (älteste Datei zuerst) Private Function getFilesInPath(ByVal sPath As String, Optional ByVal sPattern As String = "*.*") As String() sPath = IIf(Right$(sPath, 1) > Application.PathSeparator, sPath & Application.PathSeparator, sPath) & sPattern getFilesInPath = Split(Ascii2Ansi(CreateObject("wscript.shell").exec("cmd /c dir """ & sPath & """ /a:-d /o:-d").StdOut.ReadAll), vbCrLf) End Function ' Wandelt DOS-ASCII-Zeichen zu Windows-ANSI um Private Function Ascii2Ansi(ByVal sAscii As String) As String OemToChar sAscii, sAscii Ascii2Ansi = sAscii End Function

Option Explicit Private Declare PtrSafe Function OemToCharA Lib "user32" ( _ ByVal lpszSrc As String, ByVal lpszDst As String) As Long Sub listFilesInPath() Dim sPath As String, sFiles() As String, i As Long Dim oFSO As Object, sDatum As String Set oFSO = CreateObject("Scripting.FileSystemObject") sPath = "C:\Temp" ' === anpassen! sDatum = "31.05.2001" sFiles = getFilesInPath(sPath) For i = LBound(sFiles) To UBound(sFiles) - 1 With oFSO.GetFile(sPath & "\" & sFiles(i)) Debug.Print sFiles(i), .datelastmodified '.datecreated If Left$(.datelastmodified, 10) = sDatum Then MsgBox "gefunden": Exit For End If End With Next i End Sub ' Liefert die Dateinamen aller passenden Dateien im angegebenen Pfads als Stringarray in Datumsreihenfolge (älteste Datei zuerst) Private Function getFilesInPath(ByVal sPath As String, Optional ByVal sPattern As String = "*.*") As String() sPath = IIf(Right$(sPath, 1) > Application.PathSeparator, sPath & Application.PathSeparator, sPath) & sPattern getFilesInPath = Split(Ascii2Ansi(CreateObject("wscript.shell").exec("cmd /c dir """ & sPath & """ /b /a:-d /o:-d").StdOut.ReadAll), vbCrLf) End Function ' Wandelt DOS-ASCII-Zeichen zu Windows-ANSI um Private Function Ascii2Ansi(ByVal sAscii As String) As String OemToCharA sAscii, sAscii Ascii2Ansi = sAscii End Function

Hallo Ulf & Karl-Heinz,

vielen Dank für eure Mühe!

Was mir bis jetzt noch nicht ganz gefällt, dass hinsichtlich Datum ALLE Dateien des Ordners durchsucht werden müssen und das Datum dann erst via IF-Abfrage überprüft wird. Das kann bei mehr als 1000 Dateien ziemlich lange dauern und vorallem ist das dann verschwendete Zeit, wenn z.B. nur 10 Dateien in Frage kommen. Ich möchte nämlich vermeiden, dass bereits geprüfte Dateien in einen anderen Ordner verschoben werden müssen, daher auch die Bedingung mit dem Datum.

Das ist der Grund warum ich gemeint habe, ob man nicht mit Do While arbeiten kann und nur solange die nach Datum sortierten Dateien durchsucht bis das definierte Datum erreicht wurde.

Wäre super, wenn ihr Euch das nochmals ansehen könntet. Natürlich sind auch alle anderen gerne eingeladen das Thema zu lösen um eine performante Suche zu ermöglichen.

Vielen Dank!

Lg

Code:

Option Explicit

Sub ListeDateienAbDatum()
  Dim iZl As Long, iMax As Long
  Dim sPfad As String, sDatum As String, sArr() As String
  Dim bArt As Boolean, oFSO As Object
  
  Dim j
  j = Timer
  
  sPfad = "D:\Pictures\Videos\2019\"
  sDatum = "10.10.2019" ' "10.10.2019 15:54:00" 'Range("A1").value
  
  Set oFSO = CreateObject("Scripting.FileSystemObject")
  
  GetFiles iMax, sArr, oFSO.GetFolder(sPfad), sDatum, True ' Dateien in Array schaffen
  For iZl = 0 To iMax - 1
' Mach was mit mir
      Debug.Print sArr(0, iZl), sArr(1, iZl), sArr(2, iZl)
  Next iZl
  
  Set oFSO = Nothing
  
  MsgBox "Zeit: " & Timer - j
End Sub

Sub GetFiles(i As Long, sArr() As String, oPath As Object, sDatum As String, bUO As Boolean)
' Ermittelt alle relevanten Dateien in einem Array
  Dim oFile As Object, oDir As Object, Obj As Variant

  On Error Resume Next
  For Each oFile In oPath.Files                           ' Ordner durchsuchen
      If Err = 0 And CVDate(oFile.datelastmodified) >= CVDate(sDatum) Then
         With oFile
             ReDim Preserve sArr(2, i)
             sArr(0, i) = Replace(.Path, "\" & .Name, "") & "\"
             sArr(1, i) = .Name
             sArr(2, i) = .datelastmodified               ' Zuletzt geändert
             i = i + 1
         End With
      End If
  Next oFile
  
  If bUO = False Then Exit Sub                            ' Keine Unterordner =>raus
  
  For Each oDir In oPath.SubFolders                       ' Unterordner durchsuchen
      Obj = FileDateTime(oDir)
      GetFiles i, sArr, oDir, sDatum, bUO
  Next oDir
End Sub

Hallo Karl-Heinz,

die erste lösung gefällt mir besser, da ich mit dem Array wenig anfangen kann, weil wenn eine Datei im gültigen Datumsbereich liegt, muss ich im SAP prüfen, ob diese hochgeladen wurde.

Ein Problem was ich jedoch habe ist, dass bei einer Datei der Fehler 53 "Datei nicht gefunden" angezeigt wird, obwohl die Datei vorhanden ist und normal geöffnet werden kann.

Anbei mein Code:

Private Declare PtrSafe Sub OemToChar Lib "user32" Alias "OemToCharA" (ByVal StrFrom As String, ByVal StrTo As String)



' Liefert die Dateinamen aller passenden Dateien im angegebenen Pfads als Stringarray in Datumsreihenfolge (älteste Datei zuerst)

Private Function getFilesInPath(ByVal sPath As String, Optional ByVal sPattern As String = "*.xlsm") As String()

sPath = IIf(Right$(sPath, 1) > Application.PathSeparator, sPath & Application.PathSeparator, sPath) & sPattern

getFilesInPath = Split(Ascii2Ansi(CreateObject("wscript.shell").exec("cmd /c dir """ & sPath & """ /b /a:-d /o:-d").StdOut.ReadAll), vbCrLf)

End Function



' Wandelt DOS-ASCII-Zeichen zu Windows-ANSI um

Private Function Ascii2Ansi(ByVal sAscii As String) As String

OemToChar sAscii, sAscii

Ascii2Ansi = sAscii

End Function



Sub Check_uploads()



Dim WS1 As Worksheet

Dim sPath As String

sPath = "L:\GS\SOX\closed\"

'sPath = "C:\temp\"

Dim sFiles() As String

Dim i As Long

Dim oFSO As Object

Dim sDatum As String

Dim Vendor As Long

Dim Upload As Boolean

Dim mc As Object

Dim GuiStatusBar As SAPFEWSELib.GuiStatusBar

Dim Eingabewert As Byte

Dim Fdate As Long

Set WS1 = ActiveWorkbook.ActiveSheet



Application.Calculation = xlCalculationManual

Application.ScreenUpdating = False

Application.DisplayAlerts = False



If Not IsObject(Appl) Then

   Set SapGuiAuto = GetObject("SAPGUI")

   Set Appl = SapGuiAuto.GetScriptingEngine

End If

If Not IsObject(Connection) Then

   Set Connection = Appl.Children(0)

End If

If Not IsObject(session) Then

   Set session = Connection.Children(0)

End If

If IsObject(wscript) Then

   wscript.ConnectObject session, "on"

   wscript.ConnectObject Appl, "on"

End If



Set GuiStatusBar = session.FindById("wnd[0]/sbar")

Set oFSO = CreateObject("Scripting.FileSystemObject")



sDatum = WS1.Range("Date")

sFiles = getFilesInPath(sPath)



For i = LBound(sFiles) To UBound(sFiles) - 1



    With oFSO.GetFile(sPath & "\" & sFiles(i))

        Debug.Print sFiles(i), .datelastmodified  '.datecreated

        Fdate = DateValue(Left$(.datelastmodified, 10))



        If Fdate >= sDatum Then

            With CreateObject("VBScript.RegExp")

                '.Pattern = "[\d]+"

                .Pattern = "([0-9]{6})"

                Set mc = .Execute(sFiles(i))

                If (mc.Count > 0) Then

                    Vendor = mc(0)

                    

                    session.FindById("wnd[0]").maximize

                    session.FindById("wnd[0]/tbar[0]/okcd").Text = "MK03"

                    session.FindById("wnd[0]").sendVKey 0

                    session.FindById("wnd[0]/usr/chkRF02K-D0110").Selected = True

                    session.FindById("wnd[0]/usr/ctxtRF02K-LIFNR").Text = Vendor

                    session.FindById("wnd[0]").sendVKey 0

                    

                    Select Case GuiStatusBar.MessageType

                        Case "W": session.FindById("wnd[0]").sendVKey 0

                        Case "E": MsgBox session.FindById("wnd[0]/sbar/pane[0]").Text & " - Macro will be terminated!"

                        On Error Resume Next

                        session.FindById("wnd[0]/tbar[0]/btn[15]").press

                        On Error Resume Next

                        session.FindById("wnd[0]/tbar[0]/btn[15]").press

                        On Error Resume Next

                        session.FindById("wnd[1]/usr/btnSPOP-OPTION2").press

                    End Select

                    

                    session.FindById("wnd[0]/titl/shellcont/shell").pressContextButton "%GOS_TOOLBOX"

                    session.FindById("wnd[0]/titl/shellcont/shell").selectContextMenuItem "%GOS_VIEW_ATTA"

                    Set GRID1 = session.FindById("wnd[1]/usr/cntlCONTAINER_0100/shellcont/shell")

                    

                    For sapRow = 0 To GRID1.RowCount - 1

                        If GRID1.GetCellValue(sapRow, "BITM_DESCR") = Left(sFiles(i), Len(sFiles(i)) - 5) Then

                    '        session.FindById("wnd[1]").Close

                            session.FindById("wnd[1]/tbar[0]/btn[12]").press

                            session.FindById("wnd[0]/tbar[0]/btn[15]").press

                            Upload = True

                            Exit For

                        Else

                            Upload = False

                        End If

                    '    If sapRow Mod 90 And sapRow  GRID1.RowCount - 1 Then

                    '        Exit For

                    '    End If

                    Next

                    

                    If Upload = False Then

            '            Eingabewert = MsgBox("Request " & "" & Datname & "> was not uploaded - should this be done now?", vbYesNo, "Message")

            '

            '            If Eingabewert = vbNo Then

            '                session.FindById("wnd[1]/tbar[0]/btn[12]").press

            '                session.FindById("wnd[0]/tbar[0]/btn[15]").press

            '            Else

                            'Session.FindById("wnd[0]/titl/shellcont/shell").pressButton "%GOS_TOOLBOX"

                            session.FindById("wnd[1]/usr/cntlCONTAINER_0100/shellcont/shell").PressToolbarContextButton "%ATTA_CREATE"

                            session.FindById("wnd[1]/usr/cntlCONTAINER_0100/shellcont/shell").selectContextMenuItem "%GOS_PCATTA_CREA"

                            session.FindById("wnd[1]/usr/ctxtDY_PATH").Text = sPath '& "\"

                            session.FindById("wnd[1]/usr/ctxtDY_FILENAME").Text = sFiles(i) '& ".xlsm"

                            session.FindById("wnd[1]/tbar[0]/btn[0]").press

                            session.FindById("wnd[1]/tbar[0]/btn[0]").press

                            session.FindById("wnd[0]/tbar[0]/btn[15]").press

            '            End If

                    End If

                    

                    Upload = False

        

                End If

                Set mc = Nothing

            End With

        End If

    End With

Next i



Set GRID1 = Nothing

Set GuiStatusBar = Nothing

Set oFSO = Nothing



End Sub

Vielleicht fällt ja Dir / Euch etwas auf, was die Ursache sein kann;
das einzige was mir auffällt ist folgendes Sonderzeichen: Č

Vielen Dank!

Lg

Code:

Sub ListeDateienAbDatum()
  Dim sPfad As String, sDatum As String
  Dim bArt As Boolean, oFSO As Object
  
  sPfad = "D:\Pictures\Videos\2019\"
  sDatum = "10.10.2019" ' "10.10.2019 15:54:00" 'Range("A1").value
  
  Set oFSO = CreateObject("Scripting.FileSystemObject")
  GetFiles oFSO.GetFolder(sPfad), sDatum, True ' Dateien in Array schaffen
  Set oFSO = Nothing

End Sub

Sub GetFiles(oPath As Object, sDatum As String, bUO As Boolean)
' Ermittelt alle relevanten Dateien in einem Array
  Dim oFile As Object, oDir As Object, Obj As Variant

  On Error Resume Next
  For Each oFile In oPath.Files                           ' Ordner durchsuchen
      If Err = 0 And CVDate(oFile.datelastmodified) >= CVDate(sDatum) Then
         With oFile
' Mach was mit mir
             Debug.Print .Name, .datelastmodified        ' Zuletzt geändert
             i = i + 1
         End With
      End If
  Next oFile
  
  If bUO = False Then Exit Sub                            ' Keine Unterordner =>raus
  
  For Each oDir In oPath.SubFolders                       ' Unterordner durchsuchen
      Obj = FileDateTime(oDir)
      GetFiles oDir, sDatum, bUO
  Next oDir
End Sub

Beliebteste Forumthreads (12 Monate)

Dateien nur solange durchsuchen bis Ab-Datum erreicht wurde

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

209 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Dateien nur solange durchsuchen bis Ab-Datum erreicht wurde

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

209 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread