Dezelfde artikelen in een positie samenvoegen

[Jouke89]

Beste mensen,

Een vraag.
In een lijst met artikelen, staan soms dubbele artikelen. Deze artikelen staan onder elkaar, en horen bij een bepaalde positie.

Mijn doelvraag is: hoe kan ik deze artikelen samenvoegen, en de aantallen bij elkaar optellen? Let wel:
- een artikel in de positie Kasten mag niet samengevoegd worden met een dubbel artikel in de positie Extra onderdelen.
- er moet ook gekeken worden naar Merk en Typenummer.
- de totaalprijs moet verhoogd worden

Voor jullie beeldvorming:
- een positie begint altijd met "Positie: "
- deze lijst word gevuld in een userform / listbox. Is het handiger om in de userform al te kijken of een bepaald item al eens voorkomt, en dan het aantal verhogen? Ik krijg dat niet voor elkaar, omdat een artikel ook halverwege kan worden toegevoegd. Dat betekent dus dat er omhoog gekeken moet worden tot aan een regel die begint met "Positie: " en ook naar beneden tot aan een eventuele volgende "Positie: ".

Alvast dank voor het meedenken, als er vragen zijn hoor ik het graag!

Hartelijke groet,
Jouke

 

[VenA]

Met een hulpkolom en een draaitabel

 

[Jouke89]

Dank voor je moeite, slimme oplossing!

Is zoiets ook te realiseren middels een VBA oplossing..?
Ik zal het uitleggen: de artikelen worden verderop weer gebruikt in een ander userform.
Dus eigenlijk dezelfde layout als de huidige kolommen A:G, maar dan met de rijen samengevoegd en opgeteld, als waarden zodat het ingelezen kan worden in een userform..

Alvast dank...!

 

[VenA]

Veel is mogelijk. In het bestand is niets te vinden over hoe je de data verzameld/wil aanpassen. Dus maar even een beter voorbeeldje plaatsen.

 

[HSV]

Iets in de trant van?

Sub hsv()
Dim sv, i As Long, area As Range, a, b(6)
For Each area In Columns(2).SpecialCells(2).Areas
 sv = area.Offset(, -1).Resize(, 7)
 With CreateObject("scripting.dictionary")
   For i = 1 To UBound(sv)
     a = .Item(sv(i, 1) & sv(i, 2) & sv(i, 3))
     If IsEmpty(a) Then a = b
        a(0) = sv(i, 1)
        a(1) = sv(i, 2)
        a(2) = sv(i, 3)
        a(3) = a(3) + sv(i, 4)
        a(4) = sv(i, 5)
        a(5) = a(5) + sv(i, 6)
        a(6) = sv(i, 7)
     .Item(sv(i, 1) & sv(i, 2) & sv(i, 3)) = a
    Next i
   Cells(Rows.Count, 9).End(xlUp).Offset(IIf(Cells(1, 9) = "", 0, 1)).Resize(.Count, 7) = Application.Index(.items, 0, 0)
  End With
 Next area
End Sub

 

[Jouke89]

Harry,

Sprakeloos....
Dit is echt hogere wiskunde!

Achter een positie staan underscores in verband met de meerdere kolommen listbox. Bij een lege waarde ging de listbox overstuur. (per abuis niet meegenomen in de eerste voorbeeldfile)
Ik zie dat nu op basis van IsEmpty hij gaat bepalen of het een positie is.

Twee vragen:
1. is het ook mogelijk om te kijken naar een underscore
2. is het ook mogelijk om de posities te behouden? (nu staan bij de output de posities er niet meer tussen.

Alvast geweldig bedankt!
Hart.groet,
Jouke

 

[HSV]

Laat de underscores weg.

Ik zie trouwens geen Listbox.

Sub hsv()
Dim sv, i As Long, area As Range, a, b(6)
Cells(1, 9).CurrentRegion.ClearContents
For Each area In Columns(2).SpecialCells(2).Areas
 sv = area.Offset(IIf(area.Row = 1, 0, -1), -1).Resize(IIf(area.Row = 1, 1, area.Rows.Count + 1), 7)
 With CreateObject("scripting.dictionary")
   For i = 1 To UBound(sv)
     a = .Item(sv(i, 1) & sv(i, 2) & sv(i, 3))
     If IsEmpty(a) Then a = b
        a(0) = sv(i, 1)
        a(1) = sv(i, 2)
        a(2) = sv(i, 3)
        a(3) = IIf(i = 1, sv(i, 4), a(3) + sv(i, 4))
        a(4) = sv(i, 5)
        a(5) = IIf(i = 1, sv(i, 6), a(5) + sv(i, 6))
        a(6) = sv(i, 7)
     .Item(sv(i, 1) & sv(i, 2) & sv(i, 3)) = a
    Next i
   Cells(Rows.Count, 9).End(xlUp).Offset(IIf(Cells(1, 9) = "", 0, 1)).Resize(.Count, 7) = Application.Index(.items, 0, 0)
   Columns("I:O").AutoFit
  End With
 Next area
End Sub

 

[Jouke89]

Harry,

Ik ga hier verder mee komen!

Het is een behoorlijk bestand waar dit uitkomt, en heel wat werk om dat hier te kunnen plaatsen zonder gevoelige info, maar wel werkend.

Mijn dank is groot!

hart.groet,
Jouke

 

[HSV]

Graag gedaan Jouke,

Hierbij een langere code, maar de snelheid met bijna de helft reduceert.

Sub hsv()
Dim sv, ar, i As Long, area As Range, a, b(6), n As Long, j As Long, s0 As String
ReDim hs(6, 0)
Cells(1, 9).CurrentRegion.ClearContents
For Each area In Columns(2).SpecialCells(2).Areas
 sv = area.Offset(IIf(area.Row = 1, 0, -1), -1).Resize(IIf(area.Row = 1, 1, area.Rows.Count + 1), 7)
 With CreateObject("scripting.dictionary")
   For i = 1 To UBound(sv)
       s0 = sv(i, 1) & sv(i, 2) & sv(i, 3)
        If .Exists(s0) Then
          ar = .Item(s0)
          ar(4) = ar(4) + sv(i, 4)
          ar(6) = ar(6) + sv(i, 6)
          .Item(s0) = ar
         Else
          .Item(s0) = Application.Index(sv, i, 0)
        End If
    Next i
  ar = Application.Index(.items, 0, 0)
     For i = 1 To UBound(ar)
        If area.Row = 1 Then
               hs(i - 1, 0) = ar(i)
         Else
              n = n + 1
              ReDim Preserve hs(6, n)
            For j = 1 To 7
               hs(j - 1, n) = ar(i, j)
            Next j
          End If
       Next i
   End With
 Next area
   Cells(1, 9).Resize(UBound(hs, 2) + 1, 7) = Application.Transpose(hs)
   Columns("I:O").AutoFit
End Sub

Of:

Sub hsv()
Dim sv, ar, a, b(6), n As Long, j As Long, i As Long, area As Range
ReDim hs(6, 0)
Cells(1, 9).CurrentRegion.ClearContents
For Each area In Columns(2).SpecialCells(2).Areas
 sv = area.Offset(IIf(area.Row = 1, 0, -1), -1).Resize(IIf(area.Row = 1, 1, area.Rows.Count + 1), 7)
 With CreateObject("scripting.dictionary")
   For i = 1 To UBound(sv)
     a = .Item(sv(i, 1) & sv(i, 2) & sv(i, 3))
     If IsEmpty(a) Then a = b
        a(0) = sv(i, 1)
        a(1) = sv(i, 2)
        a(2) = sv(i, 3)
        a(3) = IIf(i = 1, sv(i, 4), a(3) + sv(i, 4))
        a(4) = sv(i, 5)
        a(5) = IIf(i = 1, sv(i, 6), a(5) + sv(i, 6))
        a(6) = sv(i, 7)
     .Item(sv(i, 1) & sv(i, 2) & sv(i, 3)) = a
    Next i
    ar = Application.Index(.items, 0, 0)
   For i = 1 To UBound(ar)
      If area.Row = 1 Then
             hs(i - 1, 0) = ar(i)
       Else
            n = n + 1
            ReDim Preserve hs(6, n)
          For j = 1 To 7
             hs(j - 1, n) = ar(i, j)
          Next j
        End If
     Next i
  End With
 Next area
   Cells(1, 9).Resize(UBound(hs, 2)+1, 7) = Application.Transpose(hs)
   Columns("I:O").AutoFit
End Sub

 

[Jouke89]

Voor mij is het chinees, maar ik heb ctrl c en ctrl v gedaan, en het gaat als de brandweer.

Hartelijk dank voor het meedenken!