Sommen met voorwaarden en nieuwe regels creeëren

Status
Niet open voor verdere reacties.

Mezelluf

Gebruiker
Lid geworden
26 apr 2013
Berichten
7
Hallo allemaal,

Ik ben vrij nieuw met Macros maar wel begonnen met de VBA cursus van het forum. En heb enige kennis m.b.t. programmeren, maar ik kom er niet uit.
Onderstaand is een voorbeeld van de data die verwerkt moet worden, de lijst wordt in totaal veel langer.

Inputvb.png

Nu is het zo dat ik op basis van item wil sommeren tot bijvoorbeeld >=300 quantity. Deze wil ik in Sheet2 weergeven met Item;Quantity;Req Date (Laagste van de gesommeerde aantallen)
(Als het mogelijk en niet te ingewikkeld is: Het laatste resultaat = <300 is dan moet het bij het vorige resultaat opgeteld worden)
Bij dit voorbeeld zou onderstaand voorbeeld moeten komen.

Resultvb.png

Het sommeren en weergeven lukt, echter krijg ik de logica en de juiste Req Date er niet in. Ik hoop dat het duidelijk uitgelegd is, als er vragen zijn hoor ik deze graag. Welke naam de nieuwe weergegeven waarde krijgen doen er niet heel er toe.

Alvast bedankt
 
met een voorbeeldbestand maak je het de helpers veel makkelijker! Dus als je dat kan plaatsen, graag.
 
Ik heb het voorbeeldbestand bijgevoegd.

Edit1: Nog een voorbeeld met een macro, echter doet deze alleen sommeren en niet de een nieuwe regel maken als dat x aantal bereikt is.
 

Bijlagen

  • Voorbeeld.xlsx
    8,8 KB · Weergaven: 18
  • Voorbeeld2metMacro.xlsm
    27,8 KB · Weergaven: 20
Laatst bewerkt door een moderator:
Test het eens.
Code:
Sub hsv()
Dim sv, i As Long, a, b(3), y As Long
sv = Sheets("sheet1").Cells(1).CurrentRegion
 With CreateObject("scripting.dictionary")
  For i = 2 To UBound(sv)
   a = .Item(sv(i, 2) & y)
     If IsEmpty(a) Then a = b
      If a(2) >= 400 Then
        a = b
        y = y + 1
     End If
        a(0) = a(0) & sv(i, 1)
        a(1) = sv(i, 2)
        a(2) = a(2) + sv(i, 3)
        a(3) = IIf(a(3) = "", CLng(CDate(sv(i, 4))), a(3))
     .Item(sv(i, 2) & y) = a
Next i
Sheets("sheet2").Cells(1, 6).Resize(.Count, 4) = Application.Index(.items, 0, 0)
End With
End Sub
 
Laatst bewerkt:
Heel erg bedankt voor! Hij werkt voor het bestand voorbeeld. Helaas werkt hij niet voor voorbeeld2, ik krijg de foutmelding "Subscript out of range" bij de regel a(3) = IIf. Waar zou dit aan liggen?
 
Is die ook met een sommatie van 400?

Code:
Sub hsv()
Dim sv, i As Long, a, b(2), y As Long
sv = Sheets("sheet1").Cells(1).CurrentRegion
 With CreateObject("scripting.dictionary")
  For i = 2 To UBound(sv)
   a = .Item(sv(i, 1) & y)
     If IsEmpty(a) Then a = b
      If a(1) >= 400 Then
        a = b
        y = y + 1
     End If
        a(0) = sv(i, 1)
        a(1) = a(1) + sv(i, 2)
        a(2) = IIf(a(2) = "", CLng(CDate(sv(i, 3))), a(2))
     .Item(sv(i, 1) & y) = a
Next i
Sheets("sheet2").Cells(1, 6).Resize(.Count, 3) = Application.Index(.items, 0, 0)
End With
End Sub
 
Laatst bewerkt:
Deze werkt, helemaal super! Volgens mij begin ik hem ook redelijk te begrijpen.

In het tweede voorbeeld is het >= 1200, echter zou dit volgens mij niet uit maken?

Is het ook nog mogelijk om, als er bijvoorbeeld 1230, 1600 & 80 uitkomt voor een bepaald item er 1230 & 1680 van te maken? Dus als het laatste resultaat <1200 is deze bij de vorige op te tellen?

In ieder geval heel erg bedankt voor je hulp tot nu toe! :thumb:
 
De laatste is het niet.
Dan zou er een extra lus in moeten om te kijken of het de laatste is.
Wat ik gedaan heb is dat de code kijkt of het bestaande getal in het item van de key >=1200 is en het nieuwe getal >200.
Zo ja, tel die weer bij elkaar op.

Code:
Sub hsv()
Dim sv, i As Long, a, b(2), y As Long, obj As Object, obj_2 As Object
sv = Sheets("sheet1").Cells(1).CurrentRegion
 Set obj = CreateObject("scripting.dictionary")
  For i = 2 To UBound(sv)
   a = obj(sv(i, 1) & y)
     If IsEmpty(a) Then a = b
      If a(1) >= 1200 Then
        y = y + 1
        a = b
     End If
        a(0) = sv(i, 1)
        a(1) = a(1) + sv(i, 2)
        a(2) = IIf(a(2) = "", CLng(CDate(sv(i, 3))), a(2))
     obj(sv(i, 1) & y) = a
  Next i
 y = 0
' With Sheets("sheet2").Cells(1, 6)
'  .CurrentRegion.ClearContents
'  .Resize(obj.Count, 3) = Application.Index(obj.items, 0, 0)
' End With
 sv = Application.Index(obj.items, 0, 0)


 Set obj_2 = CreateObject("scripting.dictionary")
  For i = 1 To UBound(sv)
   a = obj_2(sv(i, 1) & y)
     If IsEmpty(a) Then a = b
      If a(1) > 1200 And sv(i, 2) > 200 And Not IsEmpty(a(1)) Then
         y = y + 1
         a = b
      End If
        a(0) = sv(i, 1)
        a(1) = a(1) + sv(i, 2)
        a(2) = IIf(a(2) = "", CLng(CDate(sv(i, 3))), a(2))
     obj_2(sv(i, 1) & y) = a
   Next i
 
 
 With Sheets("sheet2").Cells(1, 10)
  .CurrentRegion.ClearContents
  .Resize(obj_2.Count, 3) = Application.Index(obj_2.items, 0, 0)
 End With
End Sub

Of:
Code:
Sub hsv()
Dim sv, i As Long, a, b(2), y As Long, obj As Object, obj_2 As Object
sv = Sheets("sheet1").Cells(1).CurrentRegion
 Set obj = CreateObject("scripting.dictionary")
  For i = 2 To UBound(sv)
   a = obj(sv(i, 1) & y)
     If IsEmpty(a) Then a = b
      If a(1) >= 1200 Then
        y = y + 1
        a = b
     End If
        a(0) = sv(i, 1)
        a(1) = a(1) + sv(i, 2)
        a(2) = IIf(a(2) = "", CLng(CDate(sv(i, 3))), a(2))
     obj(sv(i, 1) & y) = a
  Next i
 y = 0
' With Sheets("sheet2").Cells(1, 6)
'  .CurrentRegion.ClearContents
'  .Resize(obj.Count, 3) = Application.Index(obj.items, 0, 0)
' End With
 sv = Application.Index(obj.items, 0, 0)


 Set obj_2 = CreateObject("scripting.dictionary")
  For i = 1 To UBound(sv)
   a = obj_2(sv(i, 1))
     If IsEmpty(a) Then a = b
      If a(1) > 1200 And sv(i, 2) > 200 Then
         a = obj_2(sv(i, 1) & y)
         If IsEmpty(a) Then a = b
         a(0) = sv(i, 1)
         a(1) = a(1) + sv(i, 2)
         a(2) = IIf(a(2) = "", CLng(CDate(sv(i, 3))), a(2))
      obj_2(sv(i, 1) & y) = a
         y = y + 1
     Else
        a(0) = sv(i, 1)
        a(1) = a(1) + sv(i, 2)
        a(2) = IIf(a(2) = "", CLng(CDate(sv(i, 3))), a(2))
      obj_2(sv(i, 1)) = a
     End If
   Next i
 
 
 With Sheets("sheet2").Cells(1, 10)
  .CurrentRegion.ClearContents
  .Resize(obj_2.Count, 3) = Application.Index(obj_2.items, 0, 0)
 End With
End Sub
Of_2:
Code:
Sub hsv_2()
Dim sv, i As Long, a, b(2), y As Long, obj As Object, obj_2 As Object
sv = Sheets("sheet1").Cells(1).CurrentRegion
 Set obj_2 = CreateObject("scripting.dictionary")
  For i = 2 To UBound(sv)
   a = obj_2(sv(i, 1))
     If IsEmpty(a) Then a = b
      If a(1) > 1200 And sv(i, 2) > 200 Then
         a = obj_2(sv(i, 1) & y)
         If IsEmpty(a) Then a = b
         a(0) = sv(i, 1)
         a(1) = a(1) + sv(i, 2)
         a(2) = IIf(a(2) = "", CLng(CDate(sv(i, 3))), a(2))
      obj_2(sv(i, 1) & y) = a
         y = y + 1
     Else
        a(0) = sv(i, 1)
        a(1) = a(1) + sv(i, 2)
        a(2) = IIf(a(2) = "", CLng(CDate(sv(i, 3))), a(2))
      obj_2(sv(i, 1)) = a
     End If
   Next i
 
 
 With Sheets("sheet2").Cells(1, 10)
  .CurrentRegion.ClearContents
  .Resize(obj_2.Count, 3) = Application.Index(obj_2.items, 0, 0)
 End With
End Sub

Geen idee welk resultaat het beste voor je is.

Als je de code plaatst in een module en je maakt de groene tekst op als programmacode, dan zie je de verschillen naast elkaar.
 
Laatst bewerkt:
Onderstaande code geeft de juiste uitkomst. Echter zou ik het beter begrijpen. Zou het mogelijk zijn dat je een aantal opmerkingen er bij plaatst zodat ik er van kan leren?

Code:
Sub HSV()
Dim sv, i As Long                                                           ' Creert variabelen - sv = Artikel, i = aantal rijen
Dim a, b(2), y As Long
Dim obj As Object
Dim obj_2 As Object

sv = Sheets("Input").Cells(1).CurrentRegion
 Set obj = CreateObject("scripting.dictionary")                             ' Creert een scripting dictionary
  For i = 2 To UBound(sv)                                                   ' Vanaf rij 2 tot laatste rij die gevuld is
   a = obj(sv(i, 1) & y)
     If IsEmpty(a) Then a = b
      If a(1) >= 1200 Then
        y = y + 1
        a = b
     End If
        a(0) = sv(i, 1)
        a(1) = a(1) + sv(i, 2)
        a(2) = IIf(a(2) = "", CLng(CDate(sv(i, 3))), a(2))
     obj(sv(i, 1) & y) = a
  Next i
 y = 0
    With Sheets("Macro").Cells(1, 1)
    .CurrentRegion.ClearContents
    .Resize(obj.Count, 3) = Application.Index(obj.items, 0, 0)
    End With
 
sv = Application.Index(obj.items, 0, 0)
 Set obj_2 = CreateObject("scripting.dictionary")
  For i = 1 To UBound(sv)
   a = obj_2(sv(i, 1) & y)
     If IsEmpty(a) Then a = b
      If a(1) >= 1200 And sv(i, 2) > 1199 And Not IsEmpty(a(1)) Then
         y = y + 1
         a = b
      End If
        a(0) = sv(i, 1)
        a(1) = a(1) + sv(i, 2)
        a(2) = IIf(a(2) = "", CLng(CDate(sv(i, 3))), a(2))
     obj_2(sv(i, 1) & y) = a
   Next i
 With Sheets("Macro").Cells(2, 1)
  .CurrentRegion.ClearContents
  .Resize(obj_2.Count, 3) = Application.Index(obj_2.items, 0, 0)
 End With
End Sub


Bedankt!
 
Code:
Sub HSV()
    Dim sv, i  As Long                                               ' Creert variabelen - sv = Artikel, i = aantal rijen
    Dim a, b(2), y As Long                                           'b maak je hier aan als een lege array met 3 elementen (0 tot 2)
    Dim obj    As Object
    Dim obj_2  As Object

    sv = Sheets("Input").Cells(1).CurrentRegion                      'lees bereik in een array
    Set obj = CreateObject("scripting.dictionary")                   ' Creert een scripting dictionary
    For i = 2 To UBound(sv)                                          ' Vanaf rij 2 tot laatste rij die gevuld is
        a = obj(sv(i, 1) & y)                                        'a is de item in de dictionary van de key item (uit je werkblad) + een volgnr
        If IsEmpty(a) Then a = b                                     'a bestond nog niet, dus gebruik je de lege array b als start voor a
        If a(1) >= 1200 Then                                         'subtotaal <= 1200
            y = y + 1
            a = b
        End If
        a(0) = sv(i, 1)                                              'item van werkblad
        a(1) = a(1) + sv(i, 2)                                       'subtotaal quantity
        a(2) = IIf(a(2) = "", CLng(CDate(sv(i, 3))), a(2))           'zolang a(2) leeg is, éénmalig requested date erin zetten
        obj(sv(i, 1) & y) = a                                        'aangepaste dictionary-item terug in dictionary zetten
    Next i

    y = 0
    With Sheets("Macro").Cells(1, 1)                                 '1e cel voor uitvoer
        .CurrentRegion.ClearContents                                 'leegmaken
        .Resize(obj.Count, 3) = Application.Index(obj.items, 0, 0)   'items van dictionary naar daar schrijven
    End With

    sv = Application.Index(obj.items, 0, 0)                          'items van dictionary naar een array schrijven
    Set obj_2 = CreateObject("scripting.dictionary")                 'nieuwe dictionary aanmaken
    For i = 1 To UBound(sv)                                          'array aflopen
        a = obj_2(sv(i, 1) & y)                                      'uitlezen item van een bepaalde key in 2e dictionary
        If IsEmpty(a) Then a = b                                     'bestond nog niet, dan lege sjabloon nemen
        If a(1) >= 1200 And sv(i, 2) > 1199 And Not IsEmpty(a(1)) Then    'vorig subtotaal >=1200 en nieuw quantity >1199 en niet subtotaal nog leeg
            y = y + 1                                                'tellertje ophogen
            a = b                                                    'weer met lege sjabloon herstarten
        End If
        a(0) = sv(i, 1)                                              'item
        a(1) = a(1) + sv(i, 2)                                       'subtotaal
        a(2) = IIf(a(2) = "", CLng(CDate(sv(i, 3))), a(2))
        obj_2(sv(i, 1) & y) = a                                      'vernieuwde item op gepaste key in 2e dictionary schrijven
    Next i

    With Sheets("Macro").Cells(2, 1)                                 '1e cel uitvoerbereil
        .CurrentRegion.ClearContents                                 'leegmaken
        .Resize(obj_2.Count, 3) = Application.Index(obj_2.items, 0, 0)    'items van dictionary naar daar schrijven
    End With
End Sub
 
Heel erg bedankt! Ik snap het nu een stuk beter en heb er gelijk al wijzigingen in aangebracht :)!
 
Status
Niet open voor verdere reacties.
Terug
Bovenaan Onderaan