• 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.

Macro gegevens optellen een bereik opgeven

Status
Niet open voor verdere reacties.
R

RekenwonderNiels

Gebruiker
Lid geworden
29 jul 2016
Berichten
26
Beste iedereen,

Op een andere website heb ik een VBA code gevonden die bijna aan mijn wensen voldoet.

De macro kijkt indien in kolom A (kolom A = gesorteerd) of er
dubbele waarden voorkomen. Indien ja, bedragen van kolom B optellen en nog
maar 1 rij laten staan

Code: 
Sub samenvoegen()
Dim lastrij, rij, x, a
lastrij = [A65536].End(xlUp).Row
rij = 1

Do While rij < lastrij
a = Cells(rij, 1)
x = rij
Do While x < lastrij
x = x + 1
If Cells(x, 1) = a Then
Cells(rij, 2) = Cells(rij, 2) + Cells(x, 2)
Rows(x).EntireRow.Delete
lastrij = lastrij - 1
x = x - 1
End If
Loop
rij = rij + 1
Loop
End Sub

Deze code past het hele blad aan, ik zou graag deze code binnen een bereik (A10:B1000) laten werken.
Is het mogelijk om de macro te starten zodra een cel in C:C geselecteerd wordt?

Ik ben nog niet zo thuis in macro's maar wil het graag leren :)
 
Plaats je eigen bestand eens zonder vertrouwelijke info.
Misschien wordt het wel een geheel andere code dan een code die niet aan de juiste wensen voldoet.
 
Mijn doel is om barcodes te scannen.

Maar van de barcodes die hetzelfde zijn, moeten de aantallen bij elkaar worden opgeteld. (omdat de gratis app de optie mist om het aantal in te voeren).
Dus als je 2 artikelen uit het magazijn pakt, moet je de code 2x scannen.. of als je meer als 10 artikelen pakt, even het aantal op de pc wijzigen.

Met de macro van mijn eerste bericht werkt dit al, maar zoals je in mijn voorbeeld bestand ziet, verdwijnen de rijen 1 t/m 9 ook.
Daarom zou ik graag de macro binnen een bereik zetten zodat de rest van het blad niet verdwijnt.


Bekijk bijlage Voorbeeld.xlsm
 
Een geheel andere code.
Code: 
Sub hsv()
Dim sv, i As Long, a, b(2), rRng As Range
sv = Range("a9").CurrentRegion
With CreateObject("scripting.dictionary")
       For i = 1 To UBound(sv)
        a = .Item(sv(i, 1))
         If IsEmpty(a) Then a = b
            a(0) = sv(i, 1)
            a(1) = a(1) + sv(i, 2)
            a(2) = sv(i, 3)
         .Item(sv(i, 1)) = a
       Next i
     Set rRng = Range("a9")
    rRng.CurrentRegion.ClearContents
    rRng.Resize(.Count, 3) = Application.Index(.items, 0, 0)
End With
End Sub
 
Super!

Ik merk al dat jou code de regels niet verwijdert, maar de gegevens aanpast.
nu zou ik graag nog de code starten door een cel in bereik C:C te selecteren.

Code: 
Private Sub scan(ByVal Target As Range)
    If Target.Address = Range("C:C").Address Then

Ik denk met deze code?
Ik heb geprobeerd om dit boven jou code te zetten.. maar krijg foutmeldingen.
 
Code: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim sv, i As Long, a, b(2), rRng As Range

[COLOR=#0000ff]if target.column = 3 then[/COLOR]

sv = Range("a9").CurrentRegion
With CreateObject("scripting.dictionary")
       For i = 1 To UBound(sv)
        a = .Item(sv(i, 1))
         If IsEmpty(a) Then a = b
            a(0) = sv(i, 1)
            a(1) = a(1) + sv(i, 2)
            a(2) = sv(i, 3)
         .Item(sv(i, 1)) = a
       Next i
     Set rRng = Range("a9")
    rRng.CurrentRegion.ClearContents
    rRng.Resize(.Count, 3) = Application.Index(.items, 0, 0)
End With
[COLOR=#0000ff]
end if[/COLOR]

End Sub
 
Hey Harry

Bedankt voor je snelle reacties! :thumb:

Het werkte bijna.
Alleen verdween de macro uit de lijst (alt+F8) zodra ik jou laatste code als macro gebruik. ik heb het opgelost door de stappen van Joost Verdaasdonk te volgen op dit stukje van het forum.
En deze code:

Code: 
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
If Not Application.Intersect(Target, Range("C:C")) Is Nothing Then
Call hsv
End If
End Sub

op het tabblad te zetten (programmacode)

en jou eerste code:

Code: 
Sub hsv()
Dim sv, i As Long, a, b(2), rRng As Range
sv = Range("a9").CurrentRegion
With CreateObject("scripting.dictionary")
       For i = 1 To UBound(sv)
        a = .Item(sv(i, 1))
         If IsEmpty(a) Then a = b
            a(0) = sv(i, 1)
            a(1) = a(1) + sv(i, 2)
            a(2) = sv(i, 3)
         .Item(sv(i, 1)) = a
       Next i
     Set rRng = Range("a9")
    rRng.CurrentRegion.ClearContents
    rRng.Resize(.Count, 3) = Application.Index(.items, 0, 0)
End With
End Sub


Als macro te gebruiken.

Nu werkt het prima! :) maar.. is deze oplossing betrouwbaar?
 
Hallo Niels,

Als je de code zowel semi-automatisch als handmatig uit wil voeren is dat de oplossing.
De 'Application' en 'Call' mag er voor weg.

Code: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 If Not Intersect(Target, columns(3)) Is Nothing Then hsv
End Sub

Of het betrouwbaar is?; dat zul je zelf ervaren.

Succes.
 
Heb het aangepast, en het werkt!:D
Super bedankt Harry :thumb: en Joost Verdaasdonk als je dit ooit leest :p

Bij deze is mijn probleem opgelost!
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan