Servus,
das hatte ich befürchtet.
Schau mal das ist jetzt der Code für ein einziges Jahr, zeimlich lang oder?
Sub kopieren()
Dim z As Integer, r As Integer
Dim nam As String, nam1 As String, nam2 As String, nam3 As String, nam4 As String, nam5 As _
String, nam6 As String, nam7 As String, nam8 As String, nam9 As String, nam10 As String, nam11 As String, nam12 As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
r = Sheets("Tabelle1").Range("A65536").End(xlUp).Offset(0, 0).Row
nam = Sheets("Tabelle1").Name
Sheets.Add
nam1 = ActiveSheet.Name
Sheets.Add
nam2 = ActiveSheet.Name
Sheets.Add
nam3 = ActiveSheet.Name
Sheets.Add
nam4 = ActiveSheet.Name
Sheets.Add
nam5 = ActiveSheet.Name
Sheets.Add
nam6 = ActiveSheet.Name
Sheets.Add
nam7 = ActiveSheet.Name
Sheets.Add
nam8 = ActiveSheet.Name
Sheets.Add
nam9 = ActiveSheet.Name
Sheets.Add
nam10 = ActiveSheet.Name
Sheets.Add
nam11 = ActiveSheet.Name
Sheets.Add
nam12 = ActiveSheet.Name
With Sheets(nam)
For z = 1 To r Step 1
Select Case Left(.Cells(z, 1).Value, 6)
Case "200501":
.Cells(z, 1).EntireRow.Copy Destination:=Sheets(nam1).Range("A65536").End( _
xlUp).Offset(1, 0)
Case "200502":
.Cells(z, 1).EntireRow.Copy Destination:=Sheets(nam2).Range("A65536").End( _
xlUp).Offset(1, 0)
Case "200503":
.Cells(z, 1).EntireRow.Copy Destination:=Sheets(nam3).Range("A65536").End( _
xlUp).Offset(1, 0)
Case "200504":
.Cells(z, 1).EntireRow.Copy Destination:=Sheets(nam4).Range("A65536").End( _
xlUp).Offset(1, 0)
Case "200505":
.Cells(z, 1).EntireRow.Copy Destination:=Sheets(nam5).Range("A65536").End( _
xlUp).Offset(1, 0)
Case "200506":
.Cells(z, 1).EntireRow.Copy Destination:=Sheets(nam6).Range("A65536").End( _
xlUp).Offset(1, 0)
Case "200507":
.Cells(z, 1).EntireRow.Copy Destination:=Sheets(nam7).Range("A65536").End( _
xlUp).Offset(1, 0)
Case "200508":
.Cells(z, 1).EntireRow.Copy Destination:=Sheets(nam8).Range("A65536").End( _
xlUp).Offset(1, 0)
Case "200509":
.Cells(z, 1).EntireRow.Copy Destination:=Sheets(nam9).Range("A65536").End( _
xlUp).Offset(1, 0)
Case "200510":
.Cells(z, 1).EntireRow.Copy Destination:=Sheets(nam10).Range("A65536").End( _
xlUp).Offset(1, 0)
Case "200511":
.Cells(z, 1).EntireRow.Copy Destination:=Sheets(nam11).Range("A65536").End( _
xlUp).Offset(1, 0)
Case "200511":
.Cells(z, 1).EntireRow.Copy Destination:=Sheets(nam12).Range("A65536").End( _
xlUp).Offset(1, 0)
End Select
Next z
End With
With Sheets(nam1)
If .Range("A2").Value "" Then
.Name = "200501"
Else
.Delete
End If
End With
With Sheets(nam2)
If .Range("A2").Value "" Then
.Name = "200502"
Else
.Delete
End If
End With
With Sheets(nam3)
If .Range("A2").Value "" Then
.Name = "200503"
Else
.Delete
End If
End With
With Sheets(nam4)
If .Range("A2").Value "" Then
.Name = "200504"
Else
.Delete
End If
End With
With Sheets(nam5)
If .Range("A2").Value "" Then
.Name = "200505"
Else
.Delete
End If
End With
With Sheets(nam6)
If .Range("A2").Value "" Then
.Name = "200506"
Else
.Delete
End If
End With
With Sheets(nam7)
If .Range("A2").Value "" Then
.Name = "200507"
Else
.Delete
End If
End With
With Sheets(nam8)
If .Range("A2").Value "" Then
.Name = "200508"
Else
.Delete
End If
End With
With Sheets(nam9)
If .Range("A2").Value "" Then
.Name = "200509"
Else
.Delete
End If
End With
With Sheets(nam10)
If .Range("A2").Value "" Then
.Name = "200510"
Else
.Delete
End If
End With
With Sheets(nam11)
If .Range("A2").Value "" Then
.Name = "200511"
Else
.Delete
End If
End With
With Sheets(nam12)
If .Range("A2").Value "" Then
.Name = "200512"
Else
.Delete
End If
End With
Application.DisplayAlerts = False
Application.ScreenUpdating = True
End Sub
Du kannst so einen Code entweder für jedes Jahr zusammenstellen (einmalige Änderung) oder eben man kann den Code so umschreiben, dass du das Jahr eingibst und die Aktion dann ausführen lässt.
Weiterhin ist es nicht möglich, ubegrenzt viele tabellenblätter anzulegen (stark abhängig vom Arbeitsspeicher). Sollen die Tabellenblätter immer da sein oder ist das nur eine temporäre Auswertungssache.
Im 2. Fall würde ich dir eine Löschschleife empfehlen und zwar beim Öffnen oder Schließen der Datei:
Sub löschen()
Dim wks as Worksheet
Application.DisplayAlerts = False
For Each wks In activeWorkbook.Worksheets
If wks.Name "Tabelle1" Then ' Quelltabelle
wks.Delete
End if
Next wks
Application.DisplayAlerts = True
End Sub
Schau dir die Beispielmappe an, da habe ich es mit der Jahreseingabe gelöst.
https://www.herber.de/bbs/user/44487.xls
Du hast jetzt die Wahl.
Gruß
Chaos