bisheriges Makro:
Sub MehrBereichsDruck()
Dim TB1 As Worksheet, TB2 As Worksheet
Dim SA As Range
Dim i%, y%
Application.ScreenUpdating = False
AutoFit = False
'Worksheets("Gewichtsberechnung").Select
Set TB1 = ActiveSheet
Set TB2 = Worksheets.Add
TB1.Select
i = 0: y = 1
For Each SA In Selection.Areas
'MsgBox Selection.Areas(1).Address
'MsgBox Selection.Areas(1).Parent.Name
'TB2.Cells(i, 1) = "Bereich Nr. " & y
i = i + 1
SA.Copy
TB2.Select
TB2.Cells(i, 1).PasteSpecial Paste:=xlAll
i = TB2.Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
'y = y + 1
Next SA
TB2.PrintPreview
Application.DisplayAlerts = False
TB2.Delete
Application.DisplayAlerts = True
End Sub