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