script samenvoegen

[moensk]

Ik heb een data bestand waarbij kolommen dienen samengevoegd te worden.
als waarde in Kolom "I" gelijk is dan kolom "J" en "K" samentellen in 1 regel en andere regels op 0 zetten.
de lijnen mogen niet verwijdert worden das het probleem anders was dit via een simpele draaitabel opgelost.
klein voorbeeldje gemaakt.
iemand een scriptje hiervoor

 

[HansDouwe]

Ik heb een oplossing met een draaitabel en een formule gemaakt.

Ik maak toch de draaitabel en daarna ga ik in de grote tabel met de functie DRAAITABEL.OPHALEN de gegevens Som PP en Som gewicht uit de draaitabel halen zodra de ID "samen" verandert.
Als de ID hetzelfde blijft dan produceer ik 0 en 0.

Zie in bijlage de draaitabel en de formules in het groene vlak.

Kan je hier wat mee?

 

[JEC.]

Via VBA:

Sub jec()
 Dim ar, a, i As Long
 ar = Range("A2:K9")
 
 With CreateObject("scripting.dictionary")
   For i = 1 To UBound(ar)
     If Not .exists(ar(i, 9)) Then
       .Item(ar(i, 9)) = Array(ar(i, 1), ar(i, 2), ar(i, 3), ar(i, 4), ar(i, 5), ar(i, 6), ar(i, 7), ar(i, 8), ar(i, 9), ar(i, 10), ar(i, 11))
     Else
        a = .Item(ar(i, 9))
        a(9) = a(9) + ar(i, 10)
        a(10) = a(10) + ar(i, 11)
       .Item(ar(i, 9)) = a
       .Item(i) = Array(ar(i, 1), ar(i, 2), ar(i, 3), ar(i, 4), ar(i, 5), ar(i, 6), ar(i, 7), ar(i, 8), ar(i, 9), 0, 0)
     End If
   Next
   Range("A22").Resize(.Count, 11) = Application.Index(.items, 0, 0)
 End With
End Sub

 

[snb]

Sub M_snb()
  sn = UsedRange
   
  With CreateObject("scripting.dictionary")
    For j = 2 To UBound(sn)
      If Len(sn(j, 9)) > 5 Then .Item(sn(j, 9)) = .Item(sn(j, 9)) + sn(j, 10) + sn(j, 11)
    Next
     
    Cells(1, 13).Resize(.Count, 2) = Application.Transpose(Array(.keys, .items))
  End With
End Sub

 

[JEC.]

Die geeft bij mij niet het juiste resultaat.
Zie verschil:

Sub jec()
 Dim ar, a, i As Long
 ar = Range("A3:K9")
 
 With CreateObject("scripting.dictionary")
   For i = 1 To UBound(ar)
     If Not .exists(ar(i, 9)) Then
       .Item(ar(i, 9)) = Array(ar(i, 10), ar(i, 11))
     Else
        a = .Item(ar(i, 9))
        a(0) = a(0) + ar(i, 10)
        a(1) = a(1) + ar(i, 11)
       .Item(ar(i, 9)) = a
       .Item(i) = Array(0, 0)
     End If
   Next
   Range("J3").Resize(.Count, 2) = Application.Index(.items, 0, 0)
 End With
End Sub

 

[moensk]

thanks allen,
script werkt super

draaitabel.ophalen is een nuttige nieuwe functie die mij duidelijk geworden is...

 

[moensk]

kan iemand mij even uitleggen / verklaren wat dit doet

Range("J3").Resize(.Count, 2) = Application.Index(.items, 0, 0)

 

[JEC.]

Alle items uit de dictionary worden zo weggeschreven naar het bereik.
Range("J3").Resize(.Count, 2) is precies dezelfde grootte als het aantal items.

 

[moensk]

thanks,
ik heb script aangepast naar noden en wil dus 4 kolommen optellen ipv 2 (bij 2 werkt het goed)
ik heb script als volgt aangepast voor 4

bij resize(.count, 4) krijg ik de melding "type komen niet overeen"

Sub jec()
 Dim ar, a, i As Long
 ar = Range("A7:U42")
 
 With CreateObject("scripting.dictionary")
   For i = 1 To UBound(ar)
     If Not .exists(ar(i, 15)) Then
       .Item(ar(i, 15)) = Array(ar(i, 16), ar(i, 17), ar(i, 18), ar(i, 19))
     Else
        a = .Item(ar(i, 15))
        a(0) = a(0) + ar(i, 16)
        a(1) = a(1) + ar(i, 17)
        a(2) = a(2) + ar(i, 18)
        a(3) = a(3) + ar(i, 19)
       .Item(ar(i, 15)) = a
       .Item(i) = Array(0, 0)
     End If
   Next
   Range("P7").Resize(.Count, 2) = Application.Index(.items, 0, 0)
 End With
End Sub

 

[HSV]

Wat zou hier aan mankeren?

.Item(i) = Array(0, 0)

 

[moensk]

HSV
duidelijk