Sub kopiereSpalten()
Dim sh As Worksheet
Dim shAlle As Worksheet
Set shAlle = Worksheets.Add
shAlle.Name = "Zusammen"
For Each sh In Worksheets
If sh.Name <> shAlle.Name Then
Intersect(sh.UsedRange, sh.Range("B:C")).Copy
With shAlle.Range(1, Columns.Count).End(xlToLeft)
.Offset(1, 1).PasteSpecial (xlPasteValuesAndNumberFormats)
.Offset(, 1).Resize(1, 2).Value = sh.Name
End With
End If
Next
End Sub