Sub aaa()
Dim Wks As Worksheet
Dim i As Integer
With ThisWorkbook.Worksheets("table Z")
Dim OstW As Long: OstW = .Cells(Rows.Count, 4).End(xlUp).Row
If OstW > 14 Then
.Range("B14:E" & OstW).ClearContents
End If
.Range("D14:E14").Value = Array("A", "B")
.Range("B15:B19").Value = Application.Transpose(Array("X", "Y", "Z", "G", "H"))
OstW = .Cells(Rows.Count, 4).End(xlUp).Row + 1
For i = 1 To 5
For Each Wks In ThisWorkbook.Worksheets
If IsNumeric(Wks.Name) Then
If Wks.Name >= 2010 And Wks.Name <= Year(Date) Then
If i = 1 Then
Wks.Range("D15:E15").Copy .Range("D" & OstW)
.Range("C" & OstW).Value = Wks.Name
.Rows(OstW + 1).Insert Shift:=xlDown
OstW = OstW + 1
ElseIf i = 2 Then
Wks.Range("D19:E19").Copy .Range("D" & OstW + 1)
.Range("C" & OstW + 1).Value = Wks.Name
.Rows(OstW + 2).Insert Shift:=xlDown
OstW = OstW + 1
ElseIf i = 3 Then
Wks.Range("D23:E23").Copy .Range("D" & OstW + 2)
.Range("C" & OstW + 2).Value = Wks.Name
.Rows(OstW + 3).Insert Shift:=xlDown
OstW = OstW + 1
ElseIf i = 4 Then
Wks.Range("D27:E27").Copy .Range("D" & OstW + 3)
.Range("C" & OstW + 3).Value = Wks.Name
.Rows(OstW + 4).Insert Shift:=xlDown
OstW = OstW + 1
ElseIf i = 5 Then
Wks.Range("D31:E31").Copy .Range("D" & OstW + 4)
.Range("C" & OstW + 4).Value = Wks.Name
.Rows(OstW + 5).Insert Shift:=xlDown
OstW = OstW + 1
End If
End If
End If
Next Wks
Next i
End With
End Sub