Tabellenblätter kopieren und in neue Datei einfüge
19.02.2017 23:56:17
Kellner
das Makro soll folgendes tun: Habe eine aktive Mappe mit einem Tabellenblatt "Kunden", welche in Spalte 2 untereinander aufgelistet sind. Diese Namen werden nacheinander in das Tabellenblatt "Auswertung" in Zelle AJ12 eingelesen (gleiche Mappe), dann über ein Makro gefiltert. Dabei entsteht eine Auswertung zu dem jeweiligen Kunden. Soweit funktioniert das Makro. Dabei sollen die erzeugten Auswertungen für die Kunden in einer neuen Mappe gespeichert werden. Jeder Reiter soll nach dem Kundennamen, der in Zelle AJ12 eingelesen wird, bezeichnet sein. Die Mappe soll unter dem Namen der in Zelle AJ11 steht am Ende gespeichert werden. Bei mir wird für jeden Kunden eine eigene Mappe erzeugt und nicht eine gesamte Mappe mit einem Tabellenblatt je Kunde. Die Bezeichnung der Tabellenblätter ist nicht durchgängig richtig. Die Mappen heißen meist nur Excel und werden auch nicht gespeichert. Kann mir jemand weiterhelfen, habe schon viel herumprobiert und es funktioniert einfach nicht.
Sub FilternKundenname()
Dim i As Integer
Dim letztezeile As Integer
Dim Wbk As Workbook
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Mappe = ActiveWorkbook.Name
'Kundennamen aus Liste der Reihe nach einlesen
letztezeile = Sheets("Kunden").UsedRange.SpecialCells(xlCellTypeLastCell).Row
For i = 2 To letztezeile
Sheets("Kunden").Activate
Kundenname = Sheets("Kunden").Cells(i, 2).Value
Sheets("Auswertung").Activate
Sheets("Auswertung").Cells(12, 36).Value = Kundenname
' FilternAuswertung
Sheets("Tabelle 1").Range("A10:Ae15000").AdvancedFilter Action:= _
xlFilterCopy, CriteriaRange:=Range("A1:Ae2"), CopyToRange:=Range( _
"A15:Ae100"), Unique:=True
'Kopieren
Workbooks(Mappe).Activate
Sheets("Auswertung").Activate
Sheets("Auswertung").Copy
ActiveSheet.Name = Kundenname
Sheets(Kundenname).Copy After:=Workbooks(Mappe).Sheets(1)
Next i
'Neue Mappe speichern
Workbooks.Name = Range("AJ11")
ActiveWorkbook.SaveAs Filename:= _
"C:\Users\Kellner\Documents\" & Name _
, FileFormat:=xlOpenXMLWorkbook, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Application.ScreenUpdating = True
End Sub