Option Explicit
Sub TestIt()
Dim lngMonat As Long
Dim strtbName As String
Dim oWsh As Excel.Worksheet
Dim flag As Boolean
Dim x As Long, z As Long
Dim arrOrt() As String
Dim strOrt As String
Dim oWSO As Excel.Worksheet
Dim sz As Long
On Error GoTo fail
Application.ScreenUpdating = False
For lngMonat = 1 To 12
strtbName = Left(MonthName(lngMonat), 3)
flag = False
Set oWsh = Sheets(strtbName)
With oWsh
z = .Cells(.Rows.Count, 1).End(xlUp).Row
For x = 2 To z
arrOrt = Split(.Cells(x, 1).Formula, " ")
strOrt = arrOrt(0)
flag = True
Set oWSO = Sheets(strOrt)
sz = oWSO.Cells(Rows.Count, 1).End(xlUp).Row + 1
oWSO.Cells(sz, 1).Value = .Name
.Range(.Cells(x, 1), .Cells(x, 4)).Copy _
Destination:=oWSO.Cells(sz, 2)
Next x
End With
Next lngMonat
fail:
Select Case Err.Number
Case 0
Case 9
If flag = True Then
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = strOrt
ActiveSheet.Cells(1, 1).Value = "aus Monat"
ActiveSheet.Cells(1, 2).Value = oWsh.Cells(1, 1).Value
Resume
Else
MsgBox "Monatstabellen unvollständig!", vbOKOnly Or vbCritical, "Abbruch"
End
End If
Case Else
End Select
Application.ScreenUpdating = True
End Sub