Artikel summieren

Einen wunderschönen guten Abend,
ich habe ein kleine Frage an Euch und ich hoffe, dass ihr mir helfen könnt:
Ich habe eine Datei mit ca. 30000 Artikel-Datensätzen. Den Aufbau bzw.
eine Beispieldatei habe ich Euch angehängt (sind allerdings nur fiktive Daten)
Die "Aufgabe" ist nun bei den Artikeln, bei denen die ersten 7-Stellen (die 8 & 9 Stelle sind nicht wichtig) übereinstimmen, eine Leerzeile darunter einzufügen und die Werte zu summieren (siehe Beispieldatei). Zusätzlich soll in der Spalte "Division" jeweils der Ist-Wert durch den Plan-Wert gerechnet werden.
Die Artikelnummern sind schon sortiert, so dass keine Aritkelnummern zwischen
drin auftauchen könnten. Es besteht die Möglichkeit, dass z.B.: 3 Artikel mit der gleichen Nummer vorhanden sein können allerdings auch nur einer.
Kennt ja jemand ein schnelle Lösung per VBA?
Viel Spass beim Fußball schauen heut Abend!
Vielen Dank und sportlichen Gruß
Stefan
https://www.herber.de/bbs/user/91341.xlsx

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Stefan
so?
In dem Beispiel waren die Formeln nur bis X eingefügt Y und Z waren fixe Werte.
Ich gehe davon aus, dass die auch als Formeln existieren sollen.

Option Explicit
Sub ZeilenPlus()
On Error GoTo Fehler
Dim TB, i&
Dim SP%, ZE%, LR&
Dim Von&, Neu&
Dim stCalc%
'*** bescheunigt das Makro
With Application
.ScreenUpdating = False
stCalc = .Calculation
.Calculation = xlCalculationManual
End With
'*** Stammdaten Anfang
Set TB = ActiveSheet
SP = 1 'Spalte A
ZE = 4 'ab Zeile
'*** Stammdaten Ende
LR = TB.Cells(Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte
'*** Die eigentliche Routine
For i = LR To ZE Step -1
With TB
If Left(.Cells(i + 1, SP), 7)  Left(.Cells(i, SP), 7) Then
.Rows(i + 1).Insert xlDown
Neu = i + 1 ' Zeile mit den Formeln
End If
If Left(.Cells(i - 1, SP), 7)  Left(.Cells(i, SP), 7) Then
Von = i
.Range("I" & Neu & ":Z" & Neu).FormulaR1C1 = _
"=SUM(R[-" & Neu - Von & "]C:R[-1]C)"
.Range("AA" & Neu).FormulaR1C1 = "=RC[-2]/RC[-1]"
With .Range("A" & Neu & ":AA" & Neu).Interior 'Gelb färben
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
End With
Next
'*** Fehlerbehandlung
Err.Clear
Fehler:
If Err.Number  0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err. _
Clear
'*** Rücksetzen
With Application
.ScreenUpdating = True
If .Calculation  stCalc Then .Calculation = stCalc
End With
End Sub

Gruß UweD

Beliebteste Forumthreads (12 Monate)

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread