Option
Explicit
Public
NextInst
As
Date
Public
Sub
StartAutocopy()
Autocopy
End
Sub
Public
Sub
Autocopy()
Application.ScreenUpdating =
False
Application.Calculation = xlCalculationManual
Dim
fso
As
Object
, wkb
As
Workbook
Dim
Datei
As
Object
, datPfad
As
String
datPfad =
"C:::::::::"
Set
fso = CreateObject(
"Scripting.filesystemobject"
)
Application.ScreenUpdating =
False
Application.DisplayAlerts =
False
For
Each
Datei
In
fso.getfolder(datPfad).Files
Set
wkb = Workbooks.Open(datPfad & Datei, local:=
True
)
wkb.Worksheets(1).Copy After:=ThisWorkbook.Worksheets(3)
Application.DisplayAlerts =
False
wkb.Close
Application.DisplayAlerts =
True
Next
Datei
Application.ScreenUpdating =
True
Application.Calculation = xlCalculationAutomatic
NextInst = Now + TimeValue(
"24:00:00"
)
Application.OnTime NextInst,
"Autocopy"
End
Sub
Public
Sub
StopAutocopy()
On
Error
Resume
Next
Application.OnTime NextInst,
"Autocopy"
, ,
False
End
Sub