Tabelle zusammenfassen

Hallo Excel Gurus!

Habe mich heute schon mit allen moeglichen Funktionen rumgeschlagen, bin aber zu keinen Ergebnis gekommen. Vielleicht koennt ihr mir ja weiterhelfen. Es geht darum, eine Materialliste zusammenzufassen.
Hierzu ein kleines Beispiel:

Anzahl--Breite--Laenge--------Anzahl--Breite--Laenge
2---------4---------12--------------------6---------4--------10
4---------4---------14--------------------2---------8--------10
2---------4---------14------------------14---------4--------12
6---------8---------12------------------14---------8--------12
2---------8---------10--------------------6---------4--------14
8---------4---------12--------------------4---------8--------14
6---------4---------10
4---------8---------14
8---------8---------12
4---------4---------12

Es sieht in diesem Fall nicht so schwer aus, aber mein Problem ist, dass die Werte fuer die Laenge nicht standardisiert sind. D.h. es kann z.B auch mal 10,45 vorkommen...

Wuerde mich ueber jede Hilfe riesig freuen!

MfG Bernhard

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Bernhard,

im nachstehenden Makro bin ich davon ausgegangen, dass die Ausgangsdaten in den Spalten A, B und C stehen und in Zeile 1 die Überschriften stehen; ansonsten muss das Makro natürlich entsprechend angepasst werden.

Option Explicit


Sub Bernhard()
Dim c As Range
Dim Br As String, La As String
Dim Anz As Integer
Dim laR1 As Long, laR2 As Long, i As Long
Application.ScreenUpdating = False
laR1 = Cells(Rows.Count, 1).End(xlUp).Row
laR2 = Cells(Rows.Count, 4).End(xlUp).Row
If laR2 > 1 Then
Range("D2:D" & laR2).ClearContents
End If
For i = 2 To laR1
If Cells(i, 1).Interior.ColorIndex <> 45 Then
Cells(i, 1).Interior.ColorIndex = 45
Anz = Cells(i, 1).Value
Br = Cells(i, 2).Text
La = Cells(i, 3).Text
For Each c In Range("A2:A" & laR1)
If c.Interior.ColorIndex <> 45 And _
c.Offset(0, 1).Text = Br And _
c.Offset(0, 2).Text = La Then
c.Interior.ColorIndex = 45
Anz = Anz + c.Value
End If
Next c
laR2 = Cells(Rows.Count, 4).End(xlUp).Row
Range("D" & laR2 + 1).Value = Anz
Range("E" & laR2 + 1).Value = Br
Range("F" & laR2 + 1).Value = La
End If
Next i
Range("A2:A" & laR1).Interior.ColorIndex = xlNone
laR2 = Cells(Rows.Count, 4).End(xlUp).Row
Range("D2:F" & laR2).Sort Key1:=Range("F2"), Order1:=xlAscending, _
Key2:=Range("E2"), Order2:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Application.ScreenUpdating = True
End Sub

Viel Erfolg wünscht
WernerB.

P.S.: Das Forum lebt auch von den Rückmeldungen der Fragesteller an die Antworter (siehe Forums-FAQ).

Beliebteste Forumthreads (12 Monate)

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

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread