AW: Tabellenblätter zusammenfassen
27.10.2021 12:37:02
Rudi
hab nur den ersten Thread gelesen.
Nur M-Blätter:
Sub aaa()
Dim objWKS As Object, oOBJ
Dim wks As Worksheet, wksNeu As Worksheet
Set objWKS = CreateObject("scripting.dictionary")
For Each wks In Worksheets
If Left(wks.Name, 1) = "M" Then
If Len(wks.Name) = 3 Then wks.Name = wks.Name & "_"
objWKS(Left(wks.Name, 3)) = 0
End If
Next wks
For Each oOBJ In objWKS
Set wksNeu = Worksheets.Add
wksNeu.Name = oOBJ
Next
For Each wks In Worksheets
If Left(wks.Name, 1) = "M" Then
If Not objWKS.exists(wks.Name) Then
If objWKS(Left(wks.Name, 3)) = 0 Then
wks.Cells(1, 1).CurrentRegion.Copy _
Worksheets(Left(wks.Name, 3)).Cells(1, 1)
objWKS(Left(wks.Name, 3)) = 1
Else
wks.Cells(1, 1).CurrentRegion.Offset(1).Copy _
Worksheets(Left(wks.Name, 3)).Cells(Rows.Count, 1).End(xlUp).Offset(1)
End If
End If
End If
Next wks
Application.DisplayAlerts = False
For Each wks In Worksheets
If Left(wks.Name, 1) = "M" Then
If Len(wks.Name) > 3 Then wks.Delete
End If
Next
Application.DisplayAlerts = True
End Sub
Gruß
Rudi