Basartabelle bitte um schnelle hilfe
29.02.2024 09:18:07
Aspire_1
ich habe bei euch eine Super Tabelle gefunden für den anstehenden Basar/Flohmarkt bei uns.
Nur hätte jemand die Zeit mir diese zu bearbeiten?
Spalte D sollte 90 % vom Kaufpreis (bekommt der Verkäufer) enthalten und Spalte E 10 %.(Spende für den Fußballverein.
Wenn dann anschließen das Makro aufteilen gedrückt wird bekommt ja jeder Verkäufer ein neues Blatt zugeweisen, das geht ja schon. Leider müsste dann für jeden verkäufer in jedem Blatt die Endsumme sowie die 90 % die er erhält und die 10 % die Gespendet werden ausgewiesen sein.
Wäre dankbar wenn mir da einer helfen könnte. Makros sind völliges neuland für mich.
https://www.herber.de/bbs/user/167406.xls
Sub Aufteilen()
Dim wksSheet As Worksheet
Dim wksTMP As Worksheet
Dim rngRange As Range
Dim rngTMP As Range
Dim lngRow As Long
On Error GoTo Fin
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
For Each wksTMP In ThisWorkbook.Worksheets
If wksTMP.Name Like "Verk*" Then
wksTMP.Delete
End If
Next wksTMP
Set wksSheet = ThisWorkbook.Worksheets("Gesamt")
With wksSheet
Set rngRange = .Range("A1:D" & Cells(Rows.Count, 1).End(xlUp).Row)
rngRange.Sort Key1:=.Range("A2"), Order1:=xlAscending, _
Key2:=.Range("B2"), Order2:=xlAscending, _
Header:=xlYes
lngRow = 2
Do Until IsEmpty(rngRange.Cells(lngRow, 1))
If rngRange.Cells(lngRow, 1) > rngRange.Cells(lngRow - 1, 1) Then
rngRange.AutoFilter field:=1, Criteria1:=rngRange.Cells(lngRow, 1)
Set rngTMP = rngRange.SpecialCells(xlCellTypeVisible)
Worksheets.Add.Move After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "Verk_" & rngRange.Cells(lngRow, 1)
rngTMP.Copy Range("A1")
Range("D1").FormulaR1C1 = "=SUM(R[1]C[-1]:R[41]C[-1])"
Columns("A:D").AutoFit
End If
lngRow = lngRow + 1
Loop
End With
Fin:
wksSheet.AutoFilterMode = False
With Application
.Goto wksSheet.Range("A1"), True
.ScreenUpdating = True
.DisplayAlerts = True
End With
Set rngRange = Nothing
Set wksSheet = Nothing
End Sub