subposten onder hoofdpost vanuit verschillende tabbladen

gjanus · 20 jan 2020

Hallo,

Ik loop altijd te knippen en te plakken en vroeg me af of dit formule technisch (of vba) makkelijker op te lossen is.

Probleem:
Productie komt binnen op subposten
Kosten komen op hoofdpost
Subposten kunnen er iedere keer meer worden

Dus een hoofdpost kan een x aantal subposten krijgen.

Nu zou ik graag een totaalblad hebben met:
Hoofdpost nummer
Daar onder alle subnummers
Subtotaal per hoofdpost

Als er de volgende keer nieuwe gegevens gedumpt worden en hoofdpost 1 bijvoorbeeld 2 nieuwe subnummers erbij krijgt dan op het totaalblad deze wel netjes op volgorde van hoofdpost geplaatst word, dus regels tussgengevoegd worden (en subtotaal blijft kloppen).

Is dit mogelijk?

HSV · 23 jan 2020

Het resultaat in blad 'resultaat'.

gjanus · 23 jan 2020

Beste HSV dat is inderdaad hoe ik het bedoel! dankje top.

HSV · 23 jan 2020

Andere methode:

Code:

Sub hsv()
Dim hp, sp, x, cA As Object, i As Long, n As Long, s0 As String
hp = Sheets("hoofdpost").Cells(1).CurrentRegion
sp = Sheets("subpost").Cells(1).CurrentRegion
ReDim sv_2(UBound(hp) + UBound(sp) - 2, 3)
  Set cA = CreateObject("System.Collections.ArrayList")
    For i = 2 To UBound(sp)
      If Trim(sp(i, 1)) <> "" And Not cA.contains(sp(i, 2) & "|" & sp(i, 1)) Then cA.Add Trim(sp(i, 2)) & "|" & Trim(sp(i, 1)) & "|" & sp(i, 3)
    Next i
  cA.Sort


 With Sheets("resultaat").Cells(1)
   .CurrentRegion.ClearContents
   .Resize(, 4) = Array("Hoofdpost", "Subpost", "Productie", "Kosten")
    With CreateObject("scripting.dictionary")
      For Each cl In cA.toarray
        .Item(Split(cl, "|")(0)) = .Item(Split(cl, "|")(0)) + Split(cl, "|")(2) * 1
      Next cl
      For i = 0 To cA.Count - 1
         x = Application.Match(Split(cA(i), "|")(0) * 1, Application.Index(hp, 0, 1), 0)
          If IsNumeric(x) Then
           If InStr(s0, "|" & Split(cA(i), "|")(0) & "subtotaal|") = 0 Then
             s0 = s0 & "|" & Split(cA(i), "|")(0) & "subtotaal|"
                  sv_2(n, 0) = Split(cA(i), "|")(0)
                  sv_2(n, 1) = "subtotaal"
                  sv_2(n, 2) = .Item(Split(cA(i), "|")(0))
                  sv_2(n, 3) = hp(x, 2)
                           i = i - 1
            Else
                 sv_2(n, 0) = Split(cA(i), "|")(0)
                 sv_2(n, 1) = Split(cA(i), "|")(1)
                 sv_2(n, 2) = Split(cA(i), "|")(2)
            End If
            n = n + 1
          End If
         Next i
   End With
  .Cells(2, 1).Resize(UBound(sv_2), 4) = sv_2
 End With
End Sub

gjanus · 23 jan 2020

Hoi Harry,

Toch nog een vraag, krijg het er zelf niet lekker aangepast.
Het voorbeeld was vrij plat maar in de werkelijke dump staat voor de hoofdpost:
Het postnummer in kolom Q en het bedrag (dat ik nodig heb) in kolom I
En voor subpost - Het postnummer in kolom c en het bedrag in kolom G

Wat moet ik in de macro aanpassen om naar die kolommen te verwijzen?

HSV · 24 jan 2020

Plaats een bestand met de juiste bereiken, dat lijkt mij gemakkelijker.

gjanus · 29 jan 2020

Hoi Harry,

Bijgaand in de kolommen zoals de dump. en gelijk in tabel vorm. De dumps zijn in tabellen. Is het mogelijk om in VBA ook naar de tabel kolommen te verwijzen?

HSV · 29 jan 2020

Kijk maar welke het beste bij je past.

Code:

Sub hsv()
Dim hp, sp, x, cl, cA As Object, i As Long, n As Long, s0 As String
hp = Sheets("hoofdpost").ListObjects(1).DataBodyRange
sp = Sheets("subpost").ListObjects(1).DataBodyRange
ReDim sv_2(UBound(hp) + UBound(sp) - 2, 3)
  Set cA = CreateObject("System.Collections.ArrayList")
    For i = 1 To UBound(sp)
      If Trim(sp(i, 17)) <> "" And Not cA.contains(sp(i, 17) & "|" & sp(i, 2)) Then cA.Add Trim(sp(i, 17)) & "|" & Trim(sp(i, 2)) & "|" & sp(i, 3)
    Next i
  cA.Sort


 With Sheets("resultaat").Cells(1)
   .CurrentRegion.ClearContents
   .Resize(, 4) = Array("Hoofdpost", "Subpost", "Productie", "Kosten")
    With CreateObject("scripting.dictionary")
      For Each cl In cA.toarray
        .Item(Split(cl, "|")(0)) = .Item(Split(cl, "|")(0)) + Split(cl, "|")(2) * 1
      Next cl
      For i = 0 To cA.Count - 1
         x = Application.Match(Split(cA(i), "|")(0) * 1, Application.Index(hp, 0, 3), 0)
          If IsNumeric(x) Then
           If InStr(s0, "|" & Split(cA(i), "|")(0) & "subtotaal|") = 0 Then
             s0 = s0 & "|" & Split(cA(i), "|")(0) & "subtotaal|"
                  sv_2(n, 0) = Split(cA(i), "|")(0)
                  sv_2(n, 1) = "subtotaal"
                  sv_2(n, 2) = .Item(Split(cA(i), "|")(0))
                  sv_2(n, 3) = hp(x, 2)
                           i = i - 1
            Else
                 sv_2(n, 0) = Split(cA(i), "|")(0)
                 sv_2(n, 1) = Split(cA(i), "|")(1)
                 sv_2(n, 2) = Split(cA(i), "|")(2)
            End If
            n = n + 1
          End If
         Next i
   End With
  .Offset(1).Resize(UBound(sv_2), 4) = sv_2
 End With
End Sub

Code:

Sub hsv()Dim hp, sp, i As Long, cA, x, sq
hp = Sheets("hoofdpost").ListObjects(1).DataBodyRange
sp = Sheets("subpost").ListObjects(1).DataBodyRange
ReDim sv(UBound(hp) + UBound(sp), 3)


  Set cA = CreateObject("System.Collections.ArrayList")
    For i = 1 To UBound(sp)
       If Trim(sp(i, 17)) <> "" And Not cA.contains(sp(i, 17) & "|" & sp(i, 2)) Then cA.Add Trim(sp(i, 17)) & "|" & Trim(sp(i, 2)) & "|" & sp(i, 3)
    Next i
       cA.Sort
   sv = cA.toarray


 With Sheets("resultaat").Cells(1)
   .Parent.Cells.RemoveSubtotal
   .CurrentRegion.ClearContents
   .Resize(, 4) = Array("Hoofdpost", "Subpost", "Productie", "Kosten")
   .Offset(1).Resize(cA.Count) = Application.Transpose(cA.toarray)
   .Offset(1).Resize(cA.Count).TextToColumns .Parent.Cells(2, 1), , , , , , , , -1, "|"
   .CurrentRegion.Subtotal 1, xlSum, 3, , , 0  '0 is subtotaal bovenaan.
     sq = .CurrentRegion
      For i = 1 To UBound(hp)
         x = Application.Match(hp(i, 3), .Parent.Columns(1), 0)
         If IsNumeric(x) Then sq(x - 1, 4) = hp(i, 2)
      Next i
   .Resize(UBound(sq), 4) = sq
 End With
End Sub

Of:

Code:

Sub hsv()
Dim sp, hp, sq, x, i As Long, n As Long
 hp = Sheets("hoofdpost").ListObjects(1).DataBodyRange
 sp = Sheets("subpost").ListObjects(1).DataBodyRange
  ReDim a(UBound(sp), 3)
     For i = 1 To UBound(sp)
        a(n, 0) = sp(i, 17)
        a(n, 1) = sp(i, 2)
        a(n, 2) = sp(i, 3)
        n = n + 1
      Next i
  With Sheets("resultaat").Cells(1)
    .Parent.Cells.RemoveSubtotal
   .CurrentRegion.ClearContents
   .Resize(, 4) = Array("Hoofdpost", "Subpost", "Productie", "Kosten")
   .Offset(1).Resize(UBound(sp), 3) = a
   .CurrentRegion.Sort .Cells(1), , , , , , , 1
   .CurrentRegion.Subtotal 1, xlSum, 3, , , 0  '0 is subtotaal bovenaan.
     sq = .CurrentRegion
      For i = 1 To UBound(hp)
         x = Application.Match(hp(i, 3), .Parent.Columns(1), 0)
         If IsNumeric(x) Then sq(x - 1, 4) = hp(i, 2)
      Next i
   .Resize(UBound(sq), 4) = sq
 End With
End Sub

En dan de application.index nog, maar eerst maar kijken wat je keuze is.

gjanus · 4 feb 2020

Wow top HSV, sorry voor de late reactie heb aantal dagen ziek op bed gelegen en weinig laptop gezien.

Die met de automatische groepering is top! (optie 2).

Bedankt man.

HSV · 4 feb 2020

Het gaat er rond zegt men, beterschap.

Optie 2 kan ook nog zo.

Code:

Sub hsv()
Dim sp, hp, sq, x, i As Long
 hp = Sheets("hoofdpost").ListObjects(1).DataBodyRange
 sp = Sheets("subpost").ListObjects(1).DataBodyRange
  With Sheets("resultaat").Cells(1)
   .Parent.Cells.RemoveSubtotal
   .CurrentRegion.ClearContents
   .Resize(, 4) = Array("Hoofdpost", "Subpost", "Productie", "Kosten")
   .Offset(1).Resize(UBound(sp), 3) = Application.Index(sp, Evaluate("row(1:" & UBound(sp) & ")"), Array(17, 2, 3))
   .CurrentRegion.Sort .Cells(1), ,.cells(1,2) , , , , , 1
   .CurrentRegion.Subtotal 1, xlSum, 3, , , 0  '0 is subtotaal bovenaan.
     sq = .CurrentRegion.Resize(, 4)
      For i = 1 To UBound(hp)
         x = Application.Match(hp(i, 3), .Parent.Columns(1), 0)
         If IsNumeric(x) Then sq(x - 1, 4) = hp(i, 2)
      Next i
   .Resize(UBound(sq), 4) = sq
 End With
End Sub

gjanus · 5 feb 2020

Nogmaals bedankt HSV. Nog een vervolg vraag. Stel kolom a van de kosten (hoofdpost) worden de hoeveelheden gedumpt. Wat zou ik aan de code moeten veranderen om die kolom er ook bij te willen hebben?

HSV · 5 feb 2020

I.p.v. de 2 een 1.

Code:

If IsNumeric(x) Then sq(x - 1, 4) = hp(i, [COLOR=#ff0000]1[/COLOR])

gjanus · 10 feb 2020

Nogmaals bedankt, probleem opgelost

subposten onder hoofdpost vanuit verschillende tabbladen

gjanus

Gebruiker

Bijlagen

HSV

Inventaris

Bijlagen

gjanus

Gebruiker

HSV

Inventaris

gjanus

Gebruiker

HSV

Inventaris

gjanus

Gebruiker

Bijlagen

HSV

Inventaris

gjanus

Gebruiker

HSV

Inventaris

gjanus

Gebruiker

HSV

Inventaris

gjanus

Gebruiker

Nieuwste berichten

Wij waarderen jouw privacy