Kundenabrechnungen aus Tabellenblatt

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Leute,
Ich versuche es noch einmal.
Ich bräuchte einen VBA Code für folgende Aufgabenstellung:
Im Tabellenblatt sind in Spalte A Vermittlernummern eingetragen. Jede Nummer kommt mehrmals vor. Mittels VBA sollen nun alle Zeilen mit derselben Vermittlernummer in ein neues Tabellenblatt kopiert werden, wobei die Überschrift, sowie die Summenzeile (mit Teilsumme für dem der jeweiligen Vermittlernummer zugeordnete Beträge) ebenfalls kopiert werden soll.
Zur Abstimmung muss die Summe aller Teilsummen in den einzelnen Tabellenblättern wieder die Gesamtsumme laut Tabellenblatt Provisionen ergeben (Berechnung in Zelle H11 im Tabellenblatt Provisionen).
Abschließend soll jedes neue Tabellenblatt als eigene Arbeitsmappe unter "Provisionsabrechung & Vermittlernummer & Vermittler" (aus Spalten A und B) in einen bestimmten Ordner gespeichert werden.
Ich wäre sehr dankbar, wenn hier jemand helfen könnte!
Die Datei ist unter folgendem Link:
https://www.herber.de/bbs/user/139522.xlsm
LG
Elvis

Hallo
Hier ein erster Versuch. Ich verwende Spalte Z um die eindeutigen VM-NR zu bekommen. Die einzelnen Dateien werden im selben Verzeichnis gespeichert.


Option Explicit
Sub Tabellen_erstellen()
Dim i As Long
Dim lastRow As Long
Dim sheetName As String
Dim ws As Worksheet
Application.ScreenUpdating = False
With Worksheets("Provisionen")
On Error Resume Next
.ShowAllData
On Error GoTo 0
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("A7:A" & lastRow).Copy .Range("Z1")
.Range("Z1:Z" & lastRow).RemoveDuplicates Columns:=1, Header:=xlNo
For i = 1 To .Cells(.Rows.Count, "Z").End(xlUp).Row
.Range("A6").AutoFilter field:=1, Criteria1:=.Cells(i, "Z")
Worksheets.Add After:=Worksheets(Worksheets.Count)
.AutoFilter.Range.Copy ActiveSheet.Range("A1")
sheetName = ActiveSheet.Range("A2") & "_" & ActiveSheet.Range("B2")
For Each ws In ThisWorkbook.Worksheets
If ws.Name = sheetName Then
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
Next ws
ActiveSheet.Name = sheetName
lastRow = Worksheets(sheetName).Cells(Worksheets(sheetName).Rows.Count, 1).End(xlUp) _
.Row
Worksheets(sheetName).Range("G" & lastRow + 1).Formula = "=Sum(G2:G" & lastRow & ")" _
Worksheets(sheetName).Copy
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & sheetName & ".xlsx"
Application.DisplayAlerts = True
ActiveWorkbook.Close False
Next i
.Range("A1").AutoFilter
.Columns("Z").ClearContents
End With
End Sub

Beliebteste Forumthreads (12 Monate)

Kundenabrechnungen aus Tabellenblatt

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread