Oct 15, 2015

1936

Meldung Speicher voll im VB-Script

Hallo,
ich habe ein Problem mit einem VB-Script.
Es prüft in ca. 300 Excel-Tabellen, ob in der jeweils letzten Zeile ein Datum im Vergleich zum aktuellen Datum zu weit (mehr als 40 Tage) zurück liegt.
Mein Script ist so aufgebaut, das es nacheinander jede Excel-Datei öffnet, die letzte Zeile ermittelt, den Inhalt einer Spalte ausliest und prüft, wie lange dieses Datum zurückliegt.
alle Ergebnisse (Dateiname, Zeitspanne) werden in einer Tabelle aufgeführt, übersteigt die Zeitspanne 40 Tage, wird die Zelle farblich markiert.
Offensichtlich ist das Script unglücklich programmiert, nach etwa 3/4 der Dateien kommt die Fehlermeldung "Speicher voll" .
Meine Frage: Kann man das Script anders gestalten, so das auch zukünftig keine Speicherbegrenzungen auftauchen?
Vielen Dank für jeden Hinweis!
Alexander

der Code:

Option Explicit

Private Sub CommandButton2_Click()
' Dateinamen aus dem Verzeichnis einlesen
Dim strPath, strName, strFullName, file As String
Dim i As Long
i = 6
strPath = "K:\Dokumente\Test\"
strName = Dir(strPath & "*.xls", 31) ' 31 = vbDirectory + vbVolume + VbSystem + vbHidden + vbReadOnly
While strName <> ""
strFullName = strPath & strName
Worksheets("Check").Cells(i, 1) = strName
Worksheets("Check").Cells(i, 2) = FileLen(strFullName) / 1024
Worksheets("Check").Cells(i, 3) = FileDateTime(strFullName)
Worksheets("Check").Cells(i, 4) = Attr2String(GetAttr(strFullName))
i = i + 1
strName = Dir
Wend
End Sub

Function Attr2String(intAttrib As Integer) As String
' Datei-Attribute bestimmen
Attr2String = "-----"
If intAttrib And vbReadOnly Then Mid(Attr2String, 1, 1) = "R"
If intAttrib And vbHidden Then Mid(Attr2String, 2, 1) = "H"
If intAttrib And vbSystem Then Mid(Attr2String, 3, 1) = "S"
If intAttrib And vbDirectory Then Mid(Attr2String, 4, 1) = "D"
If intAttrib And vbArchive Then Mid(Attr2String, 5, 1) = "A"
End Function

Private Sub CommandButton3_Click()
' Auswertung der eingelesenen Daten
Dim bExists, aktiv As Boolean
Dim oWorkbook As Object
Dim c, lz, lz1, lz2, j, arr1 As Integer
Dim a As Long
Dim file, datum, patname, patnr, patnr_roh, menge As String
Dim astrArray, astrArray1 As Variant

lz = Worksheets("Check").Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row

For j = 6 To lz

file = Worksheets("Check").Cells(j, 1).Value
astrArray = Split(file, "_")
patname = astrArray(0)
patnr_roh = Trim(astrArray(2))
astrArray1 = Split(patnr_roh, ".")
patnr = Trim(astrArray1(0))
' prüfen, ob Datei bereits geöffnet ist
bExists = False
With Application
For Each oWorkbook In .Workbooks
If UCase$(oWorkbook.Name) = file Then
' jetzt aktivieren
Windows(oWorkbook.Name).Activate
bExists = True
Exit For
End If
Next
End With

' Mappe neu laden!
If Not bExists Then
On Error Resume Next
Workbooks.Open Filename:="K:\Dokumente\Test\" & file, ReadOnly:=True
On Error GoTo 0
End If
lz1 = Worksheets("Datenblatt").Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
datum = Worksheets("Datenblatt").Cells(lz1, 1).Value
If Worksheets("Datenblatt").CheckBox1.Value = -1 Then
aktiv = True
Else
aktiv = False
End If
Workbooks(file).Close SaveChanges:=False
Worksheets("Check").Cells(j, 5) = datum
a = Date - CDate(datum)
Worksheets("Check").Cells(j, 6) = a
If aktiv = True Then
If a > 40 Then
Worksheets("Check").Cells(j, 1).Interior.ColorIndex = 3
Worksheets("Check").Cells(j, 6).Interior.ColorIndex = 3
If menge = "" Then
menge = patname + " (" + Str(a) + "Tage)"
Else
menge = menge + " ; " + patname + " (" + Str(a) + "Tage)"
End If
End If
End If
Next j

End Sub

Please also mark the comments that contributed to the solution of the article

Content-Key: 285675

Url: https://administrator.de/contentid/285675

Printed on: April 20, 2024 at 00:04 o'clock

16 Comments

Latest comment

Hi,
also erstens: Schreib Code-Zeilen bitte innerhalb der Code-Tags, da man das sonst nur sehr bescheiden lesen kann. Und bitte die Code-Zeilen blockweise einrücken.

Wenn ich das richtig verstehe, willst Du 300(!) XLS gleichzeitig öffnen, offen halten und ggf. was darin ändern. Kommt Dir das nicht selbst etwas viel vor?

Weiterhin: Wir reden doch von VBA und nicht von VBscript? Das sind 2 verschiede Schuhe. Wenn das mit den 300 Datein gleichzeitig unbedingt sein muss, dann wäre wohlmöglich der Umstieg auf 64bit eine Lösung für Dich.

Unabhängig davon kann ich nur dazu raten, nicht zuviel Dateien gleichzeitig zu öffnen.
XLS öffnen, Daten auslesen, XLS schließen.
Nächste Datei.

Eingelesene Date auswerten
relevante XLS nochmal öffnen, Daten ändern, XLS schließen
nächste Datei

Hallo zusammen!

Was ich so rauslese ist, dass er die Dateien einzeln öffnet und wieder schließt. Das Problem liegt eher daran, das sich der Code in einem Tabellenblatt befindet in dem andere Workbooks geöffnet und das Code-Sheet nicht mehr das aktive Sheet ist.

So sollte es im Groben gehen, wobei die Workbooks unsichtbar geöffnet werden. Bereits geöffnete (sichtbare) Dateien werden ebenfalls verarbeitet und geschlossen:

Option Explicit
Option Compare Text

Private Const FilesPath = "K:\Dokumente\Test\"  

Private Const RowStart = 6

Private Const ColName = 1
Private Const ColSize = 2
Private Const ColDate = 3
Private Const ColAttr = 4
Private Const ColOpenDate = 5
Private Const ColOpenDays = 6

Private Const MaxDays = 40

Private Sub CommandButton2_Click()
    Dim objFile As Object, intRowNext As Long
    
    With Cells(RowStart, ColName).Resize(UsedRange.Rows.Count, ColOpenDays)
        .ClearContents
        .Interior.ColorIndex = xlNone
    End With
    
    intRowNext = RowStart
    
    For Each objFile In CreateObject("Scripting.FileSystemObject").GetFolder(FilesPath).Files  
        If objFile.Name Like "*.xls" Then  
            With objFile
                Cells(intRowNext, ColName).Value = .Name
                Cells(intRowNext, ColSize).Value = .Size / 1024
                Cells(intRowNext, ColDate).Value = .DateCreated
                Cells(intRowNext, ColAttr).Value = GetFileAttributes(.Attributes)
            End With
            intRowNext = intRowNext + 1
        End If
    Next
End Sub

Private Sub CommandButton3_Click()
    Dim objWks As Worksheet, objCells As Range, strFile As String
    Dim dblDate As Date, intRowEnd As Long, intDays As Long
    
    If Cells(RowStart, ColName).Text <> "" Then  
        intRowEnd = Cells(Rows.Count, ColName).End(xlUp).Row
        
        For Each objCells In Range(Cells(RowStart, ColName), Cells(intRowEnd, ColName))
            strFile = FilesPath & objCells.Value
            
            If Dir(strFile) <> "" Then  
                Set objWks = GetObject(strFile).Sheets(1)
                
                intRowEnd = objWks.Cells(objWks.Rows.Count, 1).End(xlUp).Row
                
                If intRowEnd >= RowStart Then
                    dblDate = objWks.Cells(intRowEnd, 1).Value
                    intDays = Date - dblDate
                    
                    Cells(objCells.Row, ColOpenDate).Value = dblDate
                    Cells(objCells.Row, ColOpenDays).Value = intDays
                    
                    Cells(objCells.Row, ColName).Interior.ColorIndex = xlNone
                    Cells(objCells.Row, ColOpenDays).Interior.ColorIndex = xlNone
                    
                    If objWks.Shapes("CheckBox1").OLEFormat.Object.Object.Value And intDays > MaxDays Then  
                        Cells(objCells.Row, ColName).Interior.ColorIndex = 3
                        Cells(objCells.Row, ColOpenDays).Interior.ColorIndex = 3
                    End If
                End If
                
                objWks.Parent.Close False
            End If
        Next
    End If
End Sub

Private Function GetFileAttributes(intAttributes As Long) As String
    Dim arrAttr As Variant, i As Integer
    
    arrAttr = Array(vbReadOnly, "R", vbHidden, "H", vbSystem, "S", vbDirectory, "D", vbArchive, "A")  
    
    GetFileAttributes = "-----"  
    
    For i = 0 To UBound(arrAttr) Step 2
        If arrAttr(i) And intAttributes Then
            Mid(GetFileAttributes, i / 2 + 1, 1) = arrAttr(i + 1)
        End If
    Next
End Function

Gruß Dieter

[edit] Checkbox noch hinzugefügt [/edit]
[edit 2] Codezeile 20 geändert [/edit 2]

danke erstmal, E.
Nein, die ca. 300 Dateien werden natürlich nicht gleichzeitig geöffnet, sondern nacheinander.
VBA --> ok., danke
Gruß
Alexander

Danke, Dieter,
das probiere ich morgen
Gruß
alexander

Hallo, Dieter,
es scheint so zu funktionieren!
Ich erhalte kurz vor Schluß zwar noch eine Fehlermeldung "...Automatisierungsfehler" (??), denke aber, das das mit einer falschen Angabe innerhalb einer Datei zusammenhängt. Ich prüfe das noch. Immerhin bin ich deutlich weiter gekommen als mit meinem Script.
Darf ich noch eine Frage stellen?
Ich möchte gern, das das Script nur Dateien prüft, bei denen eine Checkbox ("Checkbox1") markiert ist (also aktiv ist).
Diese Abfrage müßte also irgendwie ziemlich an den Anfang.
Wie könnte man das einbauen?
Das würde die Anzahl der zu prüfenden Dateien deutlich reduzieren.

Viele Grüße und Danke !!

Alexander

Hallo Alexander!

Darf ich noch eine Frage stellen?
Ich möchte gern, das das Script nur Dateien prüft, bei denen eine Checkbox ("Checkbox1") markiert ist (also aktiv ist).
Diese Abfrage müßte also irgendwie ziemlich an den Anfang.
Wie könnte man das einbauen?
Das würde die Anzahl der zu prüfenden Dateien deutlich reduzieren.

Um zu prüfen, ob in den einzelnen Dateien die CheckBox1 aktiv ist, muss diejenige Datei ja auch geöffnet werden, insofern würde sich zumindest an der Geschwindigkeit nix ändern. Ebensowenig an der Zeilenanzahl und den Spalten A:D, die ja über den <CommandButton2> aktualisiert werden. Was nun über den <CommandButton3> mit den Einträgen in der Spalte E:F passieren soll, musst Du ja wissen, ich habe dazu leider keinen Plan (Inhalte löschen?) ...

Den CheckBox-Test:

If objWks.Shapes("CheckBox1").OLEFormat.Object.Object.Value Then  
'.......  
End If

kannst Du zwischen den Codezeilen 52 bis 70 nach Deinen Vorstellungen einbauen...

Gruß Dieter

Danke wiederum für die Hinweise und den Code, Dieter.
Ich probiere es morgen gleich aus.

Gruß

Alexander

Hallo Alexander!

Hier nochmal mit einer verbesserten CommandButton3-Version (läuft runder):

Option Explicit
Option Compare Text

Private Const FilesPath = "K:\Dokumente\Test\"  

Private Const RowStart = 6

Private Const ColName = 1
Private Const ColSize = 2
Private Const ColDate = 3
Private Const ColAttr = 4
Private Const ColOpenDate = 5
Private Const ColOpenDays = 6

Private Const MaxDays = 40

Private Sub CommandButton2_Click()
    Dim objFile As Object, intRowNext As Long
    
    With Cells(RowStart, ColName).Resize(UsedRange.Rows.Count, ColOpenDays)
        .ClearContents
        .Interior.ColorIndex = xlNone
    End With
    
    intRowNext = RowStart
    
    For Each objFile In CreateObject("Scripting.FileSystemObject").GetFolder(FilesPath).Files  
        If objFile.Name Like "*.xls" Then  
            With objFile
                Cells(intRowNext, ColName).Value = .Name
                Cells(intRowNext, ColSize).Value = .Size / 1024
                Cells(intRowNext, ColDate).Value = .DateCreated
                Cells(intRowNext, ColAttr).Value = GetFileAttributes(.Attributes)
            End With
            intRowNext = intRowNext + 1
        End If
    Next
End Sub

Private Sub CommandButton3_Click()
    Dim objExcelApp As Object, objWks As Worksheet, objCells As Range, strFile As String
    Dim dblDate As Date, intRowEnd As Long, intDays As Long, x, y
        
    If Cells(RowStart, ColName).Text <> "" Then  
        'Neue Excel-Instanz zum unsichtbaren Auslesen der externen Dateien  
        Set objExcelApp = CreateObject("Excel.Application")  
        
        'Letzte Zeile in externen Dateien ermitteln  
        intRowEnd = Cells(Rows.Count, ColName).End(xlUp).Row
        
        'Alle farbliche Markierungen aufheben  
        Range(Cells(RowStart, ColName), Cells(intRowEnd, ColOpenDays)).Interior.ColorIndex = xlNone
        
        'Alle Inhalte in den Spalten E:F löschen  
        Range(Cells(RowStart, ColOpenDate), Cells(intRowEnd, ColOpenDays)).ClearContents
        
        'Eventuelle Fehler benutzerdefiniert verarbeiten  
        On Error Resume Next
        
        'Alle Dateinamen durchlaufen  
        For Each objCells In Range(Cells(RowStart, ColName), Cells(intRowEnd, ColName))
            strFile = FilesPath & objCells.Value
            
            'Test ob Datei existiert  
            If Dir(strFile) <> "" Then  
                'Aktuelle Datei mit Sheet(1) öffnen  
                Set objWks = objExcelApp.Workbooks.Open(strFile, False, True).Sheets(1)

                'Test CheckBox True/False  
                If objWks.Shapes("CheckBox1").OLEFormat.Object.Object.Value Then  
                    'Letzte Zeile der aktuellen Datei ermitteln  
                    intRowEnd = objWks.Cells(objWks.Rows.Count, 1).End(xlUp).Row
    
                    'Test ob ab RowStart mindestens 1 Zeile belegt ist  
                    If intRowEnd >= RowStart Then
                        'Entsprechende Daten verarbeiten...  
                        dblDate = objWks.Cells(intRowEnd, 1).Value
                        intDays = Date - dblDate
    
                        With Rows(objCells.Row)
                            .Columns(ColOpenDate).Value = dblDate
                            .Columns(ColOpenDays).Value = intDays
        
                            If intDays > MaxDays Then
                                .Columns(ColName).Interior.ColorIndex = 3
                                .Columns(ColOpenDays).Interior.ColorIndex = 3
                            End If
                        End With
                    End If
                End If
                'Aktuelle Datei schließen  
                objWks.Parent.Close False
            Else
                'Einen Fehlerwert setzen  
                Err.Raise True
            End If
            
            'Fehler zurücksetzen/auswerten (Dateizeile Spalten A:F = Rot)  
            If Err Then
                Err.Clear:  Cells(objCells.Row, ColName).Resize(1, ColOpenDays).Interior.ColorIndex = 3
            End If
        Next
        'Excel-Instanz schließen  
        objExcelApp.Quit
        MsgBox "Fertig!", vbInformation  
    End If
End Sub

Private Function GetFileAttributes(intAttributes As Long) As String
    Dim arrAttr As Variant, i As Integer
    
    arrAttr = Array(vbReadOnly, "R", vbHidden, "H", vbSystem, "S", vbDirectory, "D", vbArchive, "A")  
    
    GetFileAttributes = "-----"  
    
    For i = 0 To UBound(arrAttr) Step 2
        If arrAttr(i) And intAttributes Then
            Mid(GetFileAttributes, i / 2 + 1, 1) = arrAttr(i + 1)
        End If
    Next
End Function

Im wesentlichen sind mit <CommandButtons3> folgende Resultate zu erwarten:
Allgemeiner Dateifehler = Spalte A:F ist rot markiert
CheckBox False = Spalte E:F ist Leer
GrößerGleich MaxTage = Spalte A und F ist rot markiert

Gruß Dieter

Hallo, Dieter,

das Script läuft! Es funktoniert! danke!
Es dauert zwar rel. lange, bis es fertig ist (ca. 30min) und "es passiert" im Vordergrund nichts, man ist etwas irritiert, aber das Endergebnis paßt!
Ich danke dir für deine Mühe.
Gruß
Alexander

Hallo Alexander!

Es dauert zwar rel. lange, bis es fertig ist (ca. 30min) und "es passiert" im Vordergrund nichts, man ist etwas irritiert, aber das Endergebnis paßt!

OK, könnte man natürlich noch in der StatusBar die Dateibearbeitung anzeigen lassen...

Es gibt allerdings noch eine andere Möglichkeit, um die Daten im Turbomodus zu aktualisieren (bei mir 400 Dateien in ca. 10 Sekunden). Dazu müsstest Du aber zwei Hilfszellen in den jeweiligen Dateien definieren, in denen die entsprechenden Werte (CheckBox/LastDate) konstant abgefragt werden können.

Beispiel mit den Zellen B1 und B2:
Entwurfsmodus>CheckBox1>Rechtsklick>Eigenschaften>LinkedCell = B1 - wird B1 immer mit True/False aktualisiert
B2 = MAX(A:A) - sofern in den Zellen A1:A5 keine oder nur sehr kleine Zahlen stehen enthält B2 das letzte/größte Datum.

Gruß Dieter

Das wäre gut, wenn es rascher geht.
Es dauert über eine Stunde, bis das Script fertig ist.
Allerdings würde es viel Arbeit machen, in jeder Datei die Zellen B1 und B2 durch die Inhalte der Check-Box und des Letzten Datums zu aktualisieren.
Ich müßte ja jede Datei verändern...
Wie kann man sich den Stand des Scriptes anzeigen lassen (Du schreibst, in des Status-Bar)?
Das würde reichen, da kann man sich einrichten.
Warum dauert das Script so lange?
Nimmt das Auslesen der Checkbox so viel Zeit in Anspruch?
Gruß

Alexander

Hallo Alexander!

Allerdings würde es viel Arbeit machen, in jeder Datei die Zellen B1 und B2 durch die Inhalte der Check-Box und des Letzten Datums zu aktualisieren.

Das ließe sich auch (einmalig)-automatisiert erledigen

Warum dauert das Script so lange?

Weil jede Arbeitsmappe wegen fehlender Bezüge zum Ermitteln/Auswerten der entsprechenden Daten geöffnet und wieder geschlossen werden muss, wenn auch nicht sichtbar. Bei festen Zell-Bezügen entfällt - wie bei einer Verknüpfung - das typische Öffnen/Schließen einer Arbeitsmappe...

Nimmt das Auslesen der Checkbox so viel Zeit in Anspruch?

Nö, das Öffnen/Schließen der Arbeitsmappen...

Gruß Dieter

Ich hab' da noch ein Verständnis-Problem, Dieter.
Worin besteht der Unterschied, wenn ein Script in 300 Dateien zum einen den Wert der Checkbox und des letzten Datums abfragt, zum anderen den Inhalt zweier Felder, die automatisch im Gebrauch der Dateien aktualisiert werden.
Wenn ich Dich richtig verstanden habe, muß das Script wohl im zweiten Fall die Arbeitsmappe nicht öffnen??
Kannst Du mich aufklären?
Kannst Du mir dann (ggf.) bei der Erstellung des Codes für die Automatisierte Aktualisierung der Dateien behilflich sein, oder eine Anregung geben?
Bei neu zu erstellenden Dateien pflege ich das dann von Hand ein (sind nicht so viele).
Nochmals Vielen Dank für Deine Hilfestellung bis hierher...

Gruß
Alexander

Hallo Alexander!

Der Unterschied besteht darin, dass Excel unter seinen zahlreichen Funktionen eine Funktion beinhaltet, mit der man Zellinhalte einer bestimmten Zelladresse auf einfache/schnelle Art auslesen kann, während andere Funktionen eben nur im geöffneten Zustand einer Arbeitsmappe verfügbar sind und dazu gehören nun mal der Zugriff auf ein ActiveX-Steuerelement oder das Ermitteln einer letzten Zeile mit Inhalt und und und...

Diesen Code zum Anpassen der bestehenden Xls-Dateien in ein Modul einfügen:

Option Explicit

Private Const XlsPath = "K:\Dokumente\Test\"           'Dateipfad: Xls-Dateien  
Private Const LogFile = "K:\Dokumente\Test\Err.Log"    'Dateipfad: Log-Datei  

Private Const CellsCheckBox = "B1"                     'Zelladresse: CheckBox-Status  
Private Const CellsLastDate = "B2"                     'Zelladresse: Letztes Datum  

Public Sub Workbooks_Edit()
    Dim objExcelApp As Application, objWks As Worksheet
    Dim objFso As Object, objLogFile As Object, objFile As Object
    Dim strLogText As String, bolDisplayMode As Boolean, errCount As Integer
    
    Set objFso = CreateObject("Scripting.FileSystemObject")  
    Set objExcelApp = CreateObject("Excel.Application")  
    
    With Application
        bolDisplayMode = .DisplayStatusBar
       .DisplayStatusBar = True
    End With
    
    strLogText = "Erstellt:  " & Now & vbNewLine & vbNewLine  
    
    On Error Resume Next
    
    For Each objFile In objFso.GetFolder(XlsPath).Files
        If objFile.Name Like "*.xls" Then  
            Application.StatusBar = "Dateiverarbeitung:  " & objFile.Path  
            
            Set objWks = objExcelApp.Workbooks.Open(objFile.Path, False, False).Sheets(1)

            With objWks.Shapes("CheckBox1").OLEFormat.Object.Object  
                objWks.Range(CellsCheckBox).Value = .Value
               .LinkedCell = CellsCheckBox
            End With
            
            objWks.Range(CellsLastDate).Formula = "=MAX(A:A)"  
            objWks.Parent.Close True
            
            If Err Then
                Err.Clear:  errCount = errCount + 1
                strLogText = strLogText & "Fehler: " & objFile.Name & vbNewLine  
            End If
        End If
    Next
    
    If Not errCount Then
        strLogText = strLogText & "Alle Excel-Dateien erfolgreich angepasst!"  
    End If
    
    objFso.CreateTextFile(LogFile).Write strLogText
    objExcelApp.Quit
    
    With Application
        .StatusBar = False
        .DisplayStatusBar = bolDisplayMode
    End With
    
    Shell "Notepad.exe " & Chr(34) & LogFile & Chr(34), vbNormalFocus  
End Sub

Über die Exceloberfläche>Makros einmal ausführen. Die Verarbeitung dauert seine Zeit, die Dateinamen werden in der StatusBar eingeblendet. Am Ende wird eine Log-Datei angezeigt und falls keine fehlerhafte Dateien aufgelistet sind, kann die Log-Datei und das Modul wieder gelöscht werden...

Hier der überarbeitete Code zum auslesen der Xls-Dateien (Sheet(1).Name = "Datenblatt"):

Option Explicit
Option Compare Text

Private Const XlsPath = "K:\Dokumente\Test\"           'Dateipfad: Xls-Dateien  
Private Const LogFile = "K:\Dokumente\Test\Err.Log"    'Dateipfad: Log-Datei  

Private Const CellsCheckBox = "B1"                     'Zelladresse: CheckBox-Status  
Private Const CellsLastDate = "B2"                     'Zelladresse: Letztes Datum  

Private Const RowStart = 6

Private Const ColName = 1
Private Const ColSize = 2
Private Const ColDate = 3
Private Const ColAttr = 4
Private Const ColOpenDate = 5
Private Const ColOpenDays = 6

Private Const MaxDays = 40

Private Sub CommandButton2_Click()
    Dim objFile As Object, intRowNext As Long
    
    With Cells(RowStart, ColName).Resize(UsedRange.Rows.Count, ColOpenDays)
        .ClearContents
        .Interior.ColorIndex = xlNone
    End With
    
    intRowNext = RowStart
    
    For Each objFile In CreateObject("Scripting.FileSystemObject").GetFolder(XlsPath).Files  
        If objFile.Name Like "*.xls" Then  
            With objFile
                Cells(intRowNext, ColName).Value = .Name
                Cells(intRowNext, ColSize).Value = .Size / 1024
                Cells(intRowNext, ColDate).Value = .DateCreated
                Cells(intRowNext, ColAttr).Value = GetFileAttributes(.Attributes)
            End With
            intRowNext = intRowNext + 1
        End If
    Next
End Sub

Private Sub CommandButton3_Click()
    Dim objCells As Range, strTarget As String, valCheckBox As Variant
    Dim dblDate As Date, intRowEnd As Long, intDays As Long
    
    If Cells(RowStart, ColName).Text <> "" Then  
        'Letzte Zeile ermitteln  
        intRowEnd = Cells(Rows.Count, ColName).End(xlUp).Row
        
        'Alle farbliche Markierungen löschen  
        Range(Cells(RowStart, ColName), Cells(intRowEnd, ColOpenDays)).Interior.ColorIndex = xlNone
        
        'Alle Inhalte in den Spalten E:F löschen  
        Range(Cells(RowStart, ColOpenDate), Cells(intRowEnd, ColOpenDays)).ClearContents
        
        'Alle Dateien durchlaufen und auswerten  
        For Each objCells In Range(Cells(RowStart, ColName), Cells(intRowEnd, ColName))
            'Test ob Datei existiert  
            If Dir(XlsPath & objCells.Value) <> "" Then  
                strTarget = "'" & XlsPath & "[" & objCells.Value & "]Datenblatt'!"  
                
                valCheckBox = ExecuteExcel4Macro(strTarget & Range(CellsCheckBox).Address(, , xlR1C1))
                
                'Test CheckBox auf gültigen Wert True/False  
                If valCheckBox = True Then
                    dblDate = ExecuteExcel4Macro(strTarget & Range(CellsLastDate).Address(, , xlR1C1))
                    intDays = Date - dblDate

                    With Rows(objCells.Row)
                        .Columns(ColOpenDate).Value = dblDate
                        .Columns(ColOpenDays).Value = intDays
    
                        If intDays > MaxDays Then
                            .Columns(ColName).Interior.ColorIndex = 3
                            .Columns(ColOpenDays).Interior.ColorIndex = 3
                        End If
                    End With
                ElseIf valCheckBox <> False Then
                    Cells(objCells.Row, ColName).Resize(1, ColOpenDays).Interior.ColorIndex = 3
                End If
            Else
                Cells(objCells.Row, ColName).Resize(1, ColOpenDays).Interior.ColorIndex = 3
            End If
        Next
        
        MsgBox "Fertig!", vbInformation  
    End If
End Sub

Private Function GetFileAttributes(intAttributes As Long) As String
    Dim arrAttr As Variant, i As Integer
    
    arrAttr = Array(vbReadOnly, "R", vbHidden, "H", vbSystem, "S", vbDirectory, "D", vbArchive, "A")  
    
    GetFileAttributes = "-----"  
    
    For i = 0 To UBound(arrAttr) Step 2
        If arrAttr(i) And intAttributes Then
            Mid(GetFileAttributes, i / 2 + 1, 1) = arrAttr(i + 1)
        End If
    Next
End Function

Gruß Dieter

Beneidenswert, Dieter, wie Du das programmierst.
Ich habe beides durchgeführt, es funktioniert (nun in Sekunden)
Hab' vielen Dank dafür, das Script wird mir eine große Hilfe sein!
Danke
Gruß
Alexander

OK, dann bitte den Beitrag noch als gelöst markieren. Danke!

Gruß Dieter

German solved Question VB for Applications Development

Hotly discussed

Check of ZFW Firewallgleixnerd - 3 Comments

How to set up and configure a Linux GRE tunnelAlexWisha - 3 Comments

WIREGUARD VPN ON UDM PRO BEHIND FRITZBOX - HANDSHAKE DID NOT COMPLETEjstricker - 3 Comments

End of Support dates for Office 2016, 2019 Apps und Productivity ServersDani - 1 Comment