Option
Explicit
Const
HomeDatei =
"DUBLETTENBEREINIGUNG.xlsm"
Const
HomeDaten =
"Daten-Import"
Const
HomeListe =
"Datei-Liste"
Const
HomeZeile = 3
Const
CopyZeile = 3
Const
ListDatei =
"A1"
Const
ErrMsg =
"Abbruch! Datei existiert nicht: "
Sub
SheetsImport()
Dim
WksHome
As
Worksheet, WksList
As
Worksheet, EndLine
As
Integer
, NextLine
As
Integer
Dim
WkbCopy
As
Workbook, WksCopy
As
Worksheet, Fso
As
Object
, File
As
Object
Set
Fso = CreateObject(
"Scripting.FileSystemObject"
)
Set
WksHome = Workbooks(HomeDatei).Sheets(HomeDaten)
Set
WksList = Workbooks(HomeDatei).Sheets(HomeListe)
EndLine = GetEndLine(WksHome): NextLine = HomeZeile
If
EndLine >= HomeZeile
Then
WksHome.Rows(
"3:"
& EndLine).Cells.Clear
Application.ScreenUpdating =
False
For
Each
File
In
WksList.Range(ListDatei).CurrentRegion
If
Fso.FileExists(File) =
False
Then
Application.ScreenUpdating =
True
MsgBox ErrMsg & File, vbExclamation,
"Fehler"
:
Exit
Sub
End
If
Set
WkbCopy = Workbooks.Open(File):
Set
WksCopy = WkbCopy.Sheets(1)
EndLine = GetEndLine(WksCopy)
If
EndLine >= CopyZeile
Then
WksCopy.Rows(
"3:"
& EndLine).Copy
WksHome.Rows(NextLine).Insert Shift:=xlDown
Application.CutCopyMode =
False
WkbCopy.Saved =
True
: WkbCopy.Close
NextLine = GetEndLine(WksHome) + 1
End
If
Next
Application.ScreenUpdating =
True
End
Sub