Sub
Die_3_Naechsten()
Dim
WbA
As
Workbook, WbB
As
Workbook, Sh
Dim
Pfad
As
String
, Datei
As
String
Dim
Pos
As
Integer
, Bis
As
Integer
, i
As
Integer
Pfad = "C:\Users\Benutzerxyz\Meine Documents\Abt\Temp\"
Datei =
"B.xlsx"
Set
WbA = Workbooks(
"A.xlsm"
)
Application.ScreenUpdating =
False
Set
WbB = Workbooks.Open(Pfad & Datei)
Application.DisplayAlerts =
False
For
Each
Sh
In
WbB.Sheets
If
Sh.Name <>
"Tabelle3"
Then
Sh.Delete
Next
Application.DisplayAlerts =
True
With
WbA
Pos = .ActiveSheet.Index
Bis = Pos + 3
If
Bis > .Sheets.Count
Then
MsgBox
"Problem: keine 3 weiteren Blättr ab aktueller Position zum Kopieren vorhanden"
Bis = .Sheets.Count
End
If
For
i = Pos
To
Bis
.Sheets(i).Copy after:=WbB.Sheets(WbB.Sheets.Count)
Next
End
With
WbB.Close
True
End
Sub