VBA-Aufgabe zu lösen

[cuba]

Hallo Clever-Excel-Forum

Ich hatte diese Aufgabe schon einmal im Forum, die dann auch auf geniale Art und Weise beantwortet wurde. Nach etlichen Einträgen sehe ich jedoch, dass da drei Eintragungen einfach nicht involviert sind, finde den Fehler nicht und verzweifle beinahe daran, weil ich den Ursprung selber nicht finden kann.

Ich habe Euch die Datei beigefügt. Die drei Eintragungen befinden sich in den Zeilen 549, 550 und 556, welche ich rot markiert habe.

Mittels dem Aktualiserungs-Button sollten diese drei Aufträge ebenfalls in die Liste integriert werden, was eben nicht passiert.

Ich würde mich riesig darüber freuen, wenn mir jemand den Fehler aufzeigen kann, damit ich die Originaldatei, welche dann auch die Kundennamne beinhaltet, korrekt korrigieren darf.

Vielen Dank im Voraus
cuba

[cuba]

Tja, ohne Datei geht eben nichts... , sorry:s

[Steffl]

Hallo,

Du beziehst dich auf ein Makro aber in der Datei ist kein Makro enthalten. Könntest Du das posten?

[cuba]

Hallo

Sorry, das war jtut nicht beansichtigt......

Hier der Code.


Sub Schaltfläche2_Klicken()
Call zusammenfassen
End Sub

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("AB2014")
.Columns("g:j").ClearContents 'Inhalte der Spalten "AC:AF" löschen
.Range("g3:j3") = 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 Saplten schreiben
.Range("h4:h" & objDic1.Count) = WorksheetFunction.Transpose(objDic1.keys) 'Unicate in Spalte h
.Range("g4:g" & objDic1.Count) = WorksheetFunction.Transpose(objDic1.items) 'Summen von "St" in Spalte AC
.Range("i4:i" & objDic1.Count).FormulaLocal = "=SVERWEIS(h4;$a$4:$B$" & lngLetzte & ";2;0)" 'In Spalte AE SVERWEIS() Formel zur Ermittlung der Kundennamen
.Range("j4:j" & objDic1.Count).FormulaLocal = "=SUMMEWENN($A$4:$A$" & lngLetzte & ";h4;$E$4:$E$" & lngLetzte & ")" ''In Spalte AE SUMMEWENN()() Formel zur Ermittlung der Kundennamen
.Range("i4:i" & objDic1.Count).Value = .Range("i4:i" & objDic1.Count).Value 'Formeln mit ihren Werten überschreiben
.Range("j4:j" & objDic1.Count).Value = .Range("j4:j" & objDic1.Count).Value ''Formeln mit ihren Werten überschreiben

'erst nach Spalte AC dann nach Spalte AF absteigend sortieren
.Range("g3:j" & objDic1.Count).Sort Key1:=.Range("g4"), Order1:=xlDescending, Key2:=.Range("j4"), Order2:=xlDescending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

End With

Application.ScreenUpdating = True 'Bildschirmaktualisierung ein

End Sub

[atilla]

Hallo,

Das hatte ich im alten Beitrag aber schon festgestellt und dort gelöst.
Du hast offensichtlich dort meinen letzen Beitrag nicht gelesen.

Dort hatte ich das geschrieben:

Zitat:[/quote]
"so, hab jetzt festgestellt, dass drei Zeilen untergeschlagen wurden. Mein Fehler."

[Steffl]

Hallo,

wie Atilla bereits festgestellt hat, hast Du das Makro nicht richtig angepaßt. Das habe ich jetzt versucht und poste es mal.

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("AB2014")
      .Columns("g:j").ClearContents 'Inhalte der Spalten "AC:AF" löschen
      .Range("g3:j3") = 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 Saplten schreiben
      .Range("h4:h" & objDic1.Count + 3) = WorksheetFunction.Transpose(objDic1.keys) 'Unicate in Spalte h
      .Range("g4:g" & objDic1.Count + 3) = WorksheetFunction.Transpose(objDic1.items) 'Summen von "St" in Spalte AC
      .Range("i4:i" & objDic1.Count + 3).FormulaLocal = "=SVERWEIS(h4;$a$4:$B$" & lngLetzte & ";2;0)" 'In Spalte AE SVERWEIS() Formel zur Ermittlung der Kundennamen
      .Range("j4:j" & objDic1.Count + 3).FormulaLocal = "=SUMMEWENN($A$4:$A$" & lngLetzte & ";h4;$E$4:$E$" & lngLetzte & ")" ''In Spalte AE SUMMEWENN()() Formel zur Ermittlung der Kundennamen
      .Range("i4:i" & objDic1.Count + 3).Value = .Range("i4:i" & objDic1.Count + 3).Value 'Formeln mit ihren Werten überschreiben
      .Range("j4:j" & objDic1.Count + 3).Value = .Range("j4:j" & objDic1.Count + 3).Value ''Formeln mit ihren Werten überschreiben
      
      'erst nach Spalte AC dann nach Spalte AF absteigend sortieren
      .Range("g3:j" & objDic1.Count + 3).Sort Key1:=.Range("g4"), Order1:=xlDescending, Key2:=.Range("j4"), Order2:=xlDescending, Header:=xlYes, _
      OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
      DataOption1:=xlSortNormal
  
   End With
  
   Application.ScreenUpdating = True 'Bildschirmaktualisierung ein

End Sub

[cuba]

Hallo Attila

Vielen Dank für Deine Hilfe!

Habe den Fehler korrigieren können. Hatte Deinen Beitrag dazu in der Tat nicht gelesen.....

Gruss
cuba