Makro aus filter über Vorlage abspeichern
27.07.2015 15:34:42
Michael
Ich habe ein Probelm mit folgendem Makro:
Option Explicit
'Definition von Makroweit gültigen Variablen
Const SheetUrsprung As String = "Kundeninfo (select)"
Const PfadSpeichern As String = "C:\Users\michael_woditschka\Documents\Makrofile für RUnderwriting"
Const ErsteSpalte As Long = 2 'Liste fängt in Spalte B an (B=1 usw), hier stehen _
die Anwender
Const ErsteZeile As Long = 2 'Einträge ab Zeile 2
Const NameDerTabelle As String = "Table1" 'deine definierte Tabelle heisst "Table1"
Sub FiltereProAnwender()
Dim rGCC_POL_NUMBER As Range
Dim LastRow As Long
Dim wkbNew As Workbook
Dim wkbOld As Workbook
Dim NameOfSave As String
Dim TextPerson As String
'das Workbook merken - denn später geht es in andere Workbooks!
Set wkbOld = ActiveWorkbook
With Sheets(SheetUrsprung)
'ACHTUNG! Autofilter darf bei Makrostart NICHT gesetzt sein! Reset per Makro
ResetAutoFilter
'letzte Zeile
LastRow = .Cells(.Rows.Count, ErsteSpalte).End(xlUp).Row
'Alle Anwender durchlaufen
For Each rGCC_POL_NUMBER In .Range(.Cells(ErsteZeile, ErsteSpalte), .Cells(LastRow, _
ErsteSpalte))
'Zähle, ob der Anwender das erste mal vorkommt
If WorksheetFunction.CountIf(.Range(.Cells(ErsteZeile, ErsteSpalte), .Cells( _
rGCC_POL_NUMBER. _
Row, ErsteSpalte)), rGCC_POL_NUMBER) = 1 Then
'filtere nach Anwender
.ListObjects(NameDerTabelle).Range.AutoFilter Field:=1, Criteria1:=rGCC_POL_NUMBER. _
_
Value
'nur gefilterten Teil der Tabelle kopieren
End If
Next rGCC_POL_NUMBER
Dim wkbVorlage As Workbook
Set wkbVorlage = Workbooks.Open("C:\Users\michael_woditschka\Documents\Makrofile für _
RUnderwriting\Kundeninfo Master.xlsm")
With ThisWorkbook.Sheets("Tabelle1")
.Range("B2").Copy wkbVorlage.Sheets("Tabelle1").Range("A2")
.Range("C2").Copy wkbVorlage.Sheets("Tabelle1").Range("B2")
.Range("D2").Copy wkbVorlage.Sheets("Tabelle1").Range("C2")
.Range("E2").Copy wkbVorlage.Sheets("Tabelle1").Range("D2")
.Range("F2").Copy wkbVorlage.Sheets("Tabelle1").Range("E2")
.Range("G2").Copy wkbVorlage.Sheets("Tabelle1").Range("F2")
.Range("H2").Copy wkbVorlage.Sheets("Tabelle1").Range("G2")
.Range("I2").Copy wkbVorlage.Sheets("Tabelle1").Range("H2")
.Range("J2").Copy wkbVorlage.Sheets("Tabelle1").Range("I2")
.Range("K2").Copy wkbVorlage.Sheets("Tabelle1").Range("J2")
.Range("L2").Copy wkbVorlage.Sheets("Tabelle1").Range("K2")
.ListObjects(NameDerTabelle).Range.SpecialCells(xlCellTypeVisible).Copy
'neues Workbook öffnen und merken - neues Workbook ist automatisch im Focus!
Workbooks.Add
Set wkbNew = ActiveWorkbook
'gefilterte Tabelle einfügen und Spaltenbreiten anpassen
With ActiveSheet
.Range("A1").PasteSpecial
.Cells.EntireColumn.AutoFit
End With
'neues Workbook speichern (Displayalerts gegen "Datei existiert schon" Dialog)
NameOfSave = PfadSpeichern & "\" & "Kunde" & rGCC_POL_NUMBER.Value & ".xlsx"
Application.DisplayAlerts = False
wkbNew.SaveAs Filename:=NameOfSave, FileFormat:=xlOpenXMLWorkbook, CreateBackup:= _
False
wkbNew.Close False
Application.DisplayAlerts = True
wkbOld.Activate 'Zur sicherheit
End With
ResetAutoFilter
End Sub
Ich habe eine Basisdatei mit Spalten von A bis Z wobei in B eine Kundennummer steht.
Zuerst sollte durch einen Autofilter in Spalte B nach Nummern gefiltert werden (z.B. 5x Nummer 200) dann diese 5 Zeilen in eine Vorlagendatei kopiert werden und diese wiederum auf einem bestimmten Pfad mit Kundennummer aus Spalte B (in neuen Workbook Spalte A) und Kundenname aus Spalte C (im neuen Workbook Spalte C) gespeichert werden.
Vielen lieben Dank für Eure Hilfe!