Ich habe eine Excel mit 4 Mappen. In Mappe 4 habe ich in Spalte AD verschiedene Gruppennummern und jetzt möchte ich für jede Gruppennummer eine neue Mappe erstellt haben und die Zeilen die die gleiche Gruppennummer haben in die jeweilige Mappe kopieren.
In Zeile 1 (Also A1 bis AD1) sind die jeweiligen Überschriften, die in jeder Mappe sein sollten.
Mappe soll am Schluss den Mappenname vom Inhalt der Spalte AD haben.
Ich habe dazu folgenden Code (der mir aber einen Fehler ausgibt) :
Sub Unterteilen()
Dim oDic As Object
Dim MeAr(), ArWerte
Dim A&
Dim tempCell As Range, AktuellerBereich As Range, rngFilter As Range
Dim iCalc As Integer
Set oDic = CreateObject("Scripting.Dictionary")
With Application
iCalc = .Calculation
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
'Tabelle anpassen
With ActivSheet
'bereich anpassen, hier ohne Überschrift
MeAr = Range("AD2", .Cells(.Rows.Count, 1).End(xlUp))
Set AktuellerBereich = .UsedRange.Cells
Set tempCell = .UsedRange(1, .UsedRange.Columns.Count).Offset(0, 1).Resize(2, 1) _
For B = 1 To UBound(MeAr)
oDic(MeAr(B, 1)) = 0
Next
tempCell(1, 1) = "'" & .Cells(1, 1)
ArWerte = oDic.Keys
For A = LBound(ArWerte) To UBound(ArWerte)
tempCell(2, 1) = "'=" & ArWerte(A)
With Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
AktuellerBereich.Rows(1).Copy .Range(AktuellerBereich.Rows(1).Address)
AktuellerBereich.AdvancedFilter xlFilterCopy, tempCell, .Range( _
AktuellerBereich.Rows(1).Address)
End With
Next A
tempCell.Clear
.Select
End With
.ScreenUpdating = True
.EnableEvents = True
.Calculation = iCalc
End With
End Sub
Vielen Dank für Eure Hilfe ! Gruß Ingo