Exceldatei: Erstellungsdatum auslesen und in Spalte integrieren per VBA

Hallo an Alle,

ich wieder mal mit einem Problem.

In einem Ordner habe ich ca 500 xls Dateien mit 15 Spalten (A-O) .. Jede Datei hat mehrere Zeilen (im Schnitt ca. 900) .. In der 1. Zeile befinden sich die Überschriften.

Ich benötige jetzt eine neue Spalte (Spalte P) mit der Überschrift "Datum" .. jede Zeile in Spalte P soll mit dem Erstellungsdatum -1 Tag gefüllt werden ... -1 Tag deshalb, weil die Daten, die sich in der Tabelle befinden, Daten vom Vortag sind .. Perfekt wäre das Ganze, wenn das Erstellungsdatum auf ein Montag trifft, dass dann nicht -1 Tag gerechnet, sondern mit -3 Tage wird (für den Datenbestand aus Freitag).

Anschließend soll die Datei gespeichert und mit der nächsten Datei begonnen werden, usw. bis alle Dateien verarbeitet wurden.

Ich hoffe ihr könnt mir helfen

Vielen Dank im Voraus und viele Grüße

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 275996

Url: https://administrator.de/forum/exceldatei-erstellungsdatum-auslesen-und-in-spalte-integrieren-per-vba-275996.html

Ausgedruckt am: 30.01.2025 um 18:01 Uhr

2 Kommentare

Neuester Kommentar

Hallo abuelito,
Fingerübung

... Pfad in Zeile 2 eintragen, Dateierweiterungen in Zeile 6 wie gewünscht anpassen, freuen.
Das ganze ist als *.vbs zu speichern und auszuführen

'Pfad zu den Dokumenten  
Const strPathDocs = "C:\Excel-Dateien"  
'Logfile für eventuell auftretende Fehler  
strPathLogfile = strPathDocs & "\logfile.txt"  
'Erweiterungen der Dateien die bearbeitet werden sollen  
arrFileExtensions = Array("xls","xlsx")  

Set fso = CreateObject("Scripting.Filesystemobject")  
Set objExcel = CreateObject("Excel.Application")  
Set objShell = CreateObject("Wscript.Shell")  

Dim intDocCount, intErrCount
'Applikation anzeigen und eventuelle Dialoge für Batchbetrieb unterdrücken  
objExcel.Visible = True
objExcel.DisplayAlerts = False
objExcel.ScreenUpdating = False
'Im Ordner alle Excel-Dokumente verarbeiten ( wenn Unterordner ebenfalls verarbiette werden sollen, den zweiten Parameter auf 'True' festlegen  
parseFolders fso.GetFolder(strPathDocs), False
'Das Anzeigen von Benachrichtigungen wieder aktivieren und Excel schließen  
objExcel.DisplayAlerts = True 
objExcel.ScreenUpdating = True
objExcel.Quit
Set fso = Nothing
Set objExcel = Nothing
If intErrCount = 0 Then
	MsgBox "Es wurden insgesamt " & intDocCount & " Dokumente verarbeitet.", vbInformation, "Verarbeitung abgeschlossen"  
Else
	MsgBox "Es wurden insgesamt " & intDocCount & " Dokumente verarbeitet." & vbCrLf & "Davon ist bei " & intErrCount & " Dokumenten ein Fehler aufgetreten!", vbInformation, "Verarbeitung abgeschlossen"  
	objShell.Run "Notepad.exe " & strPathLogfile  
End If

'Ende  

Function parseFolders(fldr, boolRecursion)
    For Each file In fldr.Files
    	For i = 0 To UBound(arrFileExtensions)
			If LCase(arrFileExtensions(i)) = LCase(fso.GetExtensionName(file.Path)) Then
				intDocCount = intDocCount + 1 
	            'Fehlerbehandlung für den Fall das ein Fehler beim Öffnen eines Dokumentes auftritt  
	            On Error Resume Next
	            Set objDoc = objExcel.Workbooks.Open(file.Path)
	            If Err.Number <> 0 Then
	            	intErrCount = intErrCount + 1
	            	WriteLog "!!ERROR!! Fehler beim öffnen der Datei: -> '" & file.Path & "'"  
	            Else
	         		dCreated = file.DateCreated
	         		If Weekday(dCreated) = 2 Then
	         			dCreated = DateAdd("d",-3,dCreated)  
	         		Else	
	         			dCreated = DateAdd("d",-1,dCreated)  
	         		End If
		                With objDoc.Sheets(1)
	         			.Range ("P1").Value = "Datum"  
	         			.Range("P2", "P" & .UsedRange.SpecialCells(11).Row).Value = dCreated  
	         			With .Range("P1").EntireColumn  
	         				.AutoFit
	         				.NumberFormat = "dd.mm.yyyy"  
	         			End With
	         		End With
	         		objDoc.Save
	         		objDoc.Close
	            End if
	            Exit For
	         End If
		Next
    Next
    
    'Funktion wird rekursiv aufrufen wenn das durchsuchen aller Unterordner gewünscht ist  
    If boolRecursion Then
		For Each subFolder in fldr.SubFolders
			parseFolders subFolder, True
		Next
	End If
End Function

Function WriteLog(strText)
	Set objLog = fso.OpenTextFile(strPathLogfile,8,True)
	objLog.WriteLine(Now & " - " & strText)  
	objLog.Close
End Function

Grüße Uwe