• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

script samenvoegen

Status
Niet open voor verdere reacties.

moensk

Gebruiker
Lid geworden
23 jun 2013
Berichten
778
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
 

Bijlagen

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?
 

Bijlagen

Laatst bewerkt:
Via VBA:

Code:
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
 
Laatst bewerkt:
Code:
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
 
Die geeft bij mij niet het juiste resultaat.
Zie verschil:

Code:
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
 
thanks allen,
script werkt super

draaitabel.ophalen is een nuttige nieuwe functie die mij duidelijk geworden is...
 
kan iemand mij even uitleggen / verklaren wat dit doet

Code:
Range("J3").Resize(.Count, 2) = Application.Index(.items, 0, 0)
 
Alle items uit de dictionary worden zo weggeschreven naar het bereik.
Range("J3").Resize(.Count, 2) is precies dezelfde grootte als het aantal items.
 
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"

Code:
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
 
Wat zou hier aan mankeren?
Code:
.Item(i) = Array(0, 0)
 
Status
Niet open voor verdere reacties.
Terug
Bovenaan Onderaan