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

VBA Berekend dezelfde ID Nummer als 1

Status
Niet open voor verdere reacties.

Kirana2014

Gebruiker
Lid geworden
21 okt 2020
Berichten
55
Graag jullie hulp in Excel macro Als in kolom A het ID nummer is hetzelfde dan moet de waarde bij elkaar opgeteld worden in een nieuwe kolom.

Code:
Sub pv()
Dim r As Range, a
With CreateObject("Scripting.Dictionary")
    For Each r In Range("A2", Cells(Rows.Count, 1).End(xlUp))
        If .Exists(r.Value) Then
            a = .Item(r.Value)
            a(1, 4) = a(1, 4) + r.Offset(, 3)
            .Item(r.Value) = a
        Else
            .Item(r.Value) = r.Resize(, 4).Value
        End If
    Next
    a = Application.Transpose(Application.Transpose(.items))
    Cells(Rows.Count, 1).End(xlUp)(3, 1).Resize(UBound(a), 4) = a
    [A2].CurrentRegion.Offset(1).Delete xlUp
End With
End Sub




Alvast bedankt
 

Bijlagen

  • 2021-02-18 21_50_51-Window.png
    2021-02-18 21_50_51-Window.png
    95,2 KB · Weergaven: 36
  • Data1.xlsm
    14,1 KB · Weergaven: 22
Laatst bewerkt:
Draaitabel al geprobeerd?
 
in geen van de foto's doet de code het. Het aanpassen van de vraag nadat er al een reactie is niet de meest handige manier om te communiceren via een forum. Waarom is een draaitabel niet voldoende?
 
Code:
Sub pv()
   Dim r       As Range, a

   b = -(Range("A1").Value <> "ID")              '0 as A1="ID", 1 als <>
   Set c0 = Range("A1").CurrentRegion.Columns(1 + b)   'kolom A of kolom B afhankelijk van de inhoud van A1
   If c0.Rows.Count = 1 Then MsgBox "foutje bedankt", vbCritical: Exit Sub   'stoppen als je enkel de koprij hebt

   With CreateObject("Scripting.Dictionary")
      For Each r In c0.Offset(1).Resize(c0.Rows.Count - 1).Cells   'hier loop je iedere cel af in ofwel A-kolom ofwel B-kolom, behalve koprij
         If .Exists(r.Value) Then
            a = .Item(r.Value)
            a(1, 4) = a(1, 4) + r.Offset(, 3)
            .Item(r.Value) = a
         Else
            .Item(r.Value) = r.Resize(, 4).Value
         End If
      Next

      a = Application.Transpose(Application.Transpose(.items))
      Cells(Rows.Count, 1).End(xlUp)(3, 1 + b).Resize(UBound(a), 4) = a   'hier schrijf je weg naar ofwel je A-kolom ofwel je B-kolom
      '[A2].CurrentRegion.Offset(1).Delete xlUp   'dit even tijdelijk uitschakelen
   End With

End Sub
 
Ook een duit.
Code:
Sub hsv()
With Sheets(1).Cells(1).CurrentRegion
   .Columns(2).Offset(1).Name = "b"
    [b].Offset(, 3).Resize(.Rows.Count - 1) = [if(row(b),sumif(b,b,Offset(b,,3)))]
   .RemoveDuplicates 2, xlYes
 End With
End Sub
 
@hsv, ik heb het even moeten uitproberen om te geloven dat het werkte, dus ja.
Eigenlijk had ik een soort kringverwijzingsprobleem tussen die vierkante haakjes verwacht of een foute sommatie, maar blijkbaar wordt alles netjes in het geheugen afgewerkt en in 1 keer weggeschreven naar het blad.
Dus chapeau.
 
@Bart,
Als je het rode gedeelte zou weghalen wat eigenlijk niets om hakken heeft zou je zeggen, dan werkt het niet en krijg je in elke cel dezelfde eerste som.
[if(row(b),sumif(b,b,Offset(b,,3)))]

Ik had die van jou ook even getest of beide codes hetzelfde resultaat zouden opleveren..
1: de data wordt USA weggeschreven door array (a).
2: kolom 1 bleef leeg.
 
Laatst bewerkt:
Het rode klopt.
1. Datum USA, ja, gekend fenomeen, anders eerst even snel van numberformat wijzigen en dan terugzetten.
2. tja, wat wilde TS, moest er onderscheid gemaakt worden naargelang ID in kolom A of B stond, ik kan niet in haar hoofd kijken.
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan