AW: Ich verstehe den code nicht vom kollegen
13.10.2022 14:24:28
Pieter
Option Explicit
Public Const FilePathSrlFahrplaene = "C:Hallo"
Public Const FilePathImport = "C:import"
Sub StartAll()
Dim i As Integer
For i = 0 To 10
DoEvents
Application.Wait (Now + TimeValue("0:00:01"))
Next
Application.DisplayAlerts = False
Start ("SRL_VVS_SRL_")
Start ("SRL_TE017_")
Application.DisplayAlerts = True
For i = 0 To 10
DoEvents
Application.Wait (Now + TimeValue("0:00:01"))
Next
Application.Quit
End Sub
Sub Start(SearchFileName As String)
Dim fs As Object
Dim fVerz As Object
Dim fDatei As Object
Dim fdateien As Object
Dim XLSSavePath As String
Dim XLSLoadPath As String
Dim ErrMsg As String
On Error GoTo Catch
XLSLoadPath = FilePathSrlFahrplaene
XLSSavePath = FilePathImport
Set fs = CreateObject("scripting.FileSystemObject")
Set fVerz = fs.getFolder(XLSLoadPath)
Set fdateien = fVerz.Files
For Each fDatei In fdateien
If InStr(fDatei, SearchFileName) > 0 And fDatei.Type = "Microsoft Excel 97-2003 Worksheet" Then
Workbooks.Open Filename:=fDatei.Path
Blatt_ergaenzen
WorkbookSaveAs fDatei.Name, XLSLoadPath
WorkbookSaveAs fDatei.Name, XLSSavePath
ActiveWorkbook.Close SaveChanges:=False
fDatei.delete
End If
DoEvents
Next fDatei
Exit Sub
Catch:
ErrMsg = "Error # " & Str(Err.Number) & " was generated by " & Err.Source & Chr(13) & "Error Line: " & Erl & Chr(13) & Err.Description
ActiveWorkbook.Close SaveChanges:=False
End Sub
Sub Blatt_ergaenzen()
Dim LastRow As Long
'LastRow = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
LastRow = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
' erste Spalte einfügen
Columns("A:A").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
' Datum in die erste Spalte vor die Uhrzeit kopieren
Range("D1").Select
Selection.Copy
Range("A18:A" & LastRow - 1).Select
ActiveSheet.Paste
' letzte Zeile löschen, da BoFiT sonst einen Fehler anzeigt
LastRow = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
Rows(LastRow & ":" & LastRow).Select
Selection.delete Shift:=xlUp
End Sub
Sub WorkbookSaveAs(Name As String, SavePath As String)
Dim FilePathName As String
' Datei im xlsx-Format abspeichern
If InStrRev(Name, ".") >= 1 Then Name = Left(Name, InStrRev(Name, ".") - 1)
FilePathName = SavePath & "\" & Name & ".xlsx"
' Datei löschen falls sie existiert
If Dir(FilePathName) "" Then Kill FilePathName
ActiveWorkbook.SaveAs Filename:=FilePathName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End Sub
Und so sieht eine Datei aus :
Name SRL_TE017_20220927
ich denke mit realen bedingungen ist es am besten,
es erkennt den namen nicht ..