Probleme mit Pivottabelle

[cuba]

Hoppla, jetzt hat es funktioniert. Muss mir mal ansehen, was ich da alles verkehrt gemacht habe.

Vielen Dank an Euch beide!

LG
cuba

[atilla]

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.

[atilla]

Hallo Cuba,

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 Sub

[cuba]

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