27.11.2014, 17:44
Hoppla, jetzt hat es funktioniert. Muss mir mal ansehen, was ich da alles verkehrt gemacht habe.
Vielen Dank an Euch beide!
LG
cuba
Vielen Dank an Euch beide!
LG
cuba
Seiten: 1 2
27.11.2014, 17:44
27.11.2014, 18:21
Hallo Cuba,
wenn ich das richtig beobachtet habe, scheinen ein paar Daten zu fehlen.
Ich schau mir das nachher noch einmal an, was ich da vermurkst habe.
wenn ich das richtig beobachtet habe, scheinen ein paar Daten zu fehlen.
Ich schau mir das nachher noch einmal an, was ich da vermurkst habe.
27.11.2014, 20:47
Hallo Cuba,
so, hab jetzt festgestellt, dass drei Zeilen untergeschlagen wurden. Mein Fehler.
Ersetz bitte den gesamten Code mit diesem:
so, hab jetzt festgestellt, dass drei Zeilen untergeschlagen wurden. Mein Fehler.
Ersetz bitte den gesamten Code mit diesem:
Code:
Sub zusammenfassen()
Dim i As Long
Dim lngLetzte As Long
Dim vntA
Dim feld
Dim objDic1
Set objDic1 = CreateObject("Scripting.Dictionary")
'Überschriften
vntA = Array("Order", "KND-Nr.", "Kunde", "Umsatz")
Application.ScreenUpdating = False 'Bildschirmaktualisierung aus
With Worksheets("Tabelle1")
.Columns("AC:AF").ClearContents 'Inhalte der Spalten "AC:AF" löschen
.Range("AC3:AF3") = vntA 'Überschriften in den Bereich "AC3:AF3" eintragen
lngLetzte = .Cells(.Rows.Count, 1).End(xlUp).Row 'letzte belegte Zeile in Spalte A
feld = .Range("A4:E" & lngLetzte) 'Bereich AC3 bis AF bis zur letzten belgeten in ein Variant Array schreiben
For i = LBound(feld) To UBound(feld) 'Alle Array Zeilen durchlaufen
If feld(i, 1) <> 0 Then 'wenn Zelle in Spalte nicht 0 dann einlesen
objDic1(feld(i, 1)) = objDic1(feld(i, 1)) + feld(i, 4) 'Unicate in Dictionary einlesen und die Spalte D aufaddieren
End If
Next i
'Daten in die entsprechenden Spalten schreiben
.Range("AD4:AD" & objDic1.Count + 3) = WorksheetFunction.Transpose(objDic1.keys) 'Unicate in Spalte AD
.Range("AC4:AC" & objDic1.Count + 3) = WorksheetFunction.Transpose(objDic1.items) 'Summen von "St" in Spalte AC
.Range("AE4:AE" & objDic1.Count + 3).FormulaLocal = "=SVERWEIS(AD4;$A$4:$B$" & lngLetzte & ";2;0)" 'In Spalte AE SVERWEIS() Formel zur Ermittlung der Kundennamen
.Range("AF4:AF" & objDic1.Count + 3).FormulaLocal = "=SUMMEWENN($A$4:$A$" & lngLetzte & ";AD4;$E$4:$E$" & lngLetzte & ")" ''In Spalte AE SUMMEWENN()() Formel zur Ermittlung der Kundennamen
.Range("AE4:AE" & objDic1.Count + 3).Value = .Range("AE4:AE" & objDic1.Count + 3).Value 'Formeln mit ihren Werten überschreiben
.Range("AF4:AF" & objDic1.Count + 3).Value = .Range("AF4:AF" & objDic1.Count + 3).Value ''Formeln mit ihren Werten überschreiben
'Nach Spalte AC absteigend sortieren
.Range("AC3:AF" & objDic1.Count + 3).Sort Key1:=.Range("AC4"), Order1:=xlDescending, Key2:=.Range("AF4"), Order2:=xlDescending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End With
Application.ScreenUpdating = True 'Bildschirmaktualisierung ein
End Sub14.12.2014, 13:06
Hallo Attila
Nein, tut mir leid, ich habe den Eintrag tatsächlich nicht gesehen, sorry.
Konnte es jetzt nachbessern
herzlichen Dank und schöne Festtage
cbua
Nein, tut mir leid, ich habe den Eintrag tatsächlich nicht gesehen, sorry.
Konnte es jetzt nachbessern
herzlichen Dank und schöne Festtage
cbua
Seiten: 1 2