Samenvatting maken uit meerdere tabellen VBA

Status
Niet open voor verdere reacties.
R

royb73

Gebruiker
Lid geworden
19 sep 2012
Berichten
228
Beste,

Ik wil een samenvatting m.b.v. VBA maken uit meerdere tabellen op basis van unieke gegevens (voorwaarde van toepassing op meerdere kolommen).

In dit Excel voorbeeld staat beschreven wat de bedoeling is.

Bekijk bijlage Test_samenvatting.xlsx

Alvast bedankt.

Mvg

Roy
 
Een .xlsx bestand kan geen VBA bevatten.
Die is nu bij het opsturen verloren gegaan.
 
Beste SNB. Er zat geen vba code in. Ik ben op zoek naar een vba code voor dit.

Mvg
Roy
 
Misschien toch.
Code: 
Sub hsv()
Dim sv, area, arr, a, b(3), i As Long, sector As Long, obj As Object
Set obj = CreateObject("scripting.dictionary")
With Blad2
arr = .Range("e4:e60")
 For sector = 1 To 3
  For Each area In Array("tabel5", "tabel57", "tabel59")
   sv = .ListObjects(area).DataBodyRange
     For i = 1 To UBound(arr)
       If arr(i, 1) = sector Then
          If sv(i, 1) <> "" And sv(i, 5) <> "" Then
             a = obj(arr(i, 1) & sv(i, 1) & sv(i, 2))
               If IsEmpty(a) Then a = b
                 a(0) = arr(i, 1)
                 a(1) = sv(i, 1)
                 a(2) = sv(i, 2)
                 a(3) = a(3) + sv(i, 5)
                obj(arr(i, 1) & sv(i, 1) & sv(i, 2)) = a
          End If
        End If
      Next i
   Next area
 .Cells(85, 1).Offset(, sector * 6 - 1).Resize(obj.Count, 4) = Application.Index(obj.items, 0, 0)
 obj.RemoveAll
 Next sector
 End With
 End Sub

Of ook de resultaten met nul.
Code: 
Sub hsv()
Dim sv, area, arr, a, b(3), i As Long, sector As Long, obj As Object
Set obj = CreateObject("scripting.dictionary")
With Blad2
arr = .Range("e4:e60")
 For sector = 1 To 3
  For Each area In Array("tabel5", "tabel57", "tabel59")
   sv = .ListObjects(area).DataBodyRange
     For i = 1 To UBound(arr)
       If arr(i, 1) = sector Then
          If sv(i, 1) <> "" Then
             a = obj(arr(i, 1) & sv(i, 1) & sv(i, 2))
               If IsEmpty(a) Then a = b
                 a(0) = arr(i, 1)
                 a(1) = sv(i, 1)
                 a(2) = sv(i, 2)
                 a(3) = a(3) + IIf(sv(i, 5) = "", 0, sv(i, 5))
                obj(arr(i, 1) & sv(i, 1) & sv(i, 2)) = a
          End If
        End If
      Next i
   Next area
 .Cells(85, 1).Offset(, sector * 6 - 1).Resize(obj.Count, 4) = Application.Index(obj.items, 0, 0)
 obj.RemoveAll
 Next sector
 End With
 End Sub

Of met twee lussen minder maar twee dictionary's meer.
Code: 
Sub hsv()
Dim sv, a, b(3), i As Long, obj1 as object, obj2 as object, obj3 As Object
Set obj1 = CreateObject("scripting.dictionary")
Set obj2 = CreateObject("scripting.dictionary")
Set obj3 = CreateObject("scripting.dictionary")
With Blad2
 sv = .Range("E4:V60")
     For i = 1 To UBound(sv)
      With Choose(sv(i, 1), obj1, obj2, obj3)
      
        If sv(i, 2) <> "" Then
          a = .Item(sv(i, 1) & sv(i, 2) & sv(i, 3))
               If IsEmpty(a) Then a = b
                 a(0) = sv(i, 1)
                 a(1) = sv(i, 2)
                 a(2) = sv(i, 3)
                 a(3) = a(3) + IIf(sv(i, 6) = "", 0, sv(i, 6))
                 .Item(sv(i, 1) & sv(i, 2) & sv(i, 3)) = a
          End If
        
        If sv(i, 8) <> "" Then
             a = .Item(sv(i, 1) & sv(i, 8) & sv(i, 9))
               If IsEmpty(a) Then a = b
                 a(0) = sv(i, 1)
                 a(1) = sv(i, 8)
                 a(2) = sv(i, 9)
                 a(3) = a(3) + IIf(sv(i, 12) = "", 0, sv(i, 12))
                .Item(sv(i, 1) & sv(i, 8) & sv(i, 9)) = a
            End If
        
        If sv(i, 14) <> "" Then
             a = .Item(sv(i, 1) & sv(i, 14) & sv(i, 15))
               If IsEmpty(a) Then a = b
                 a(0) = sv(i, 1)
                 a(1) = sv(i, 14)
                 a(2) = sv(i, 15)
                 a(3) = a(3) + IIf(sv(i, 18) = "", 0, sv(i, 18))
                .Item(sv(i, 1) & sv(i, 14) & sv(i, 15)) = a
             End If
        End With
      Next i
  .Cells(85, 6).Resize(obj1.Count, 4) = Application.Index(obj1.items, 0, 0)
  .Cells(85, 12).Resize(obj2.Count, 4) = Application.Index(obj2.items, 0, 0)
  .Cells(85, 18).Resize(obj3.Count, 4) = Application.Index(obj3.items, 0, 0)
 End With
 End Sub
 
Laatst bewerkt:
Harry,

Bedankt voor de codes. Ze werken prima.

Ik zie bij de eerste twee codes het verschil niet in resultaat (ligt meer aan mij denk ik). Volgens mij doen beiden codes hetzelfde qua uitkomst.

Is het nog mogelijk om de aantallen (uit kolommen H, N en T) nog tussen te stoppen per type?
Is het ook mogelijk om het te sorteren op sector - Soort - Typen bv.:

Sector Soort Type Aantal Totaal vermogen
1 Gloeilamp 1x58 12 142
1 Gloeilamp 1x60 2 76
1 LED 1x12 20 28
1 PL_C_2p 1x10 28 128
1 PL_C_2p 2x09 20 152
1 PL_C_2p 2x10 55 160
1 TLD 1x18 51 710
1 TLD 1x36 25 1056
1 TLD 1x58 122 4206
etc.

Ook zou ik nog de totale som van Totaal Vermogen per sector willen weten.

Mvg

Roy
 
Laatst bewerkt:
Dank je Harry. Werkt prima!

Kan je nog alleen de totale som laten uitrekenen van de Totale vermogen per sector?
Sector 1 zou dan 7605 moeten zijn.
Sector 2 5020.
Sector 3 5409.

Mvg
Roy
 
Met sortering en de som.
Code: 
Sub hsv()
Dim sv, a, b(4), i As Long, obj1 As Object, obj2 As Object, obj3 As Object
Set obj1 = CreateObject("scripting.dictionary")
Set obj2 = CreateObject("scripting.dictionary")
Set obj3 = CreateObject("scripting.dictionary")
With Blad2
 sv = .Range("E4:V60")
     For i = 1 To UBound(sv)
      With Choose(sv(i, 1), obj1, obj2, obj3)
      
        If sv(i, 2) <> "" Then
          a = .Item(sv(i, 1) & sv(i, 2) & sv(i, 3))
               If IsEmpty(a) Then a = b
                 a(0) = sv(i, 1)
                 a(1) = sv(i, 2)
                 a(2) = sv(i, 3)
                 a(3) = a(3) + IIf(sv(i, 4) = "", 0, sv(i, 4))
                 a(4) = a(4) + IIf(sv(i, 6) = "", 0, sv(i, 6))
                 .Item(sv(i, 1) & sv(i, 2) & sv(i, 3)) = a
          End If
        
        If sv(i, 8) <> "" Then
             a = .Item(sv(i, 1) & sv(i, 8) & sv(i, 9))
               If IsEmpty(a) Then a = b
                 a(0) = sv(i, 1)
                 a(1) = sv(i, 8)
                 a(2) = sv(i, 9)
                 a(3) = a(3) + IIf(sv(i, 10) = "", 0, sv(i, 10))
                 a(4) = a(4) + IIf(sv(i, 12) = "", 0, sv(i, 12))
                .Item(sv(i, 1) & sv(i, 8) & sv(i, 9)) = a
            End If
        
        If sv(i, 14) <> "" Then
             a = .Item(sv(i, 1) & sv(i, 14) & sv(i, 15))
               If IsEmpty(a) Then a = b
                 a(0) = sv(i, 1)
                 a(1) = sv(i, 14)
                 a(2) = sv(i, 15)
                 a(3) = a(3) + IIf(sv(i, 16) = "", 0, sv(i, 16))
                 a(4) = a(4) + IIf(sv(i, 18) = "", 0, sv(i, 18))
                .Item(sv(i, 1) & sv(i, 14) & sv(i, 15)) = a
             End If
        End With
      Next i
    .Cells(85, 6).Resize(obj1.Count, 5) = Application.Index(obj1.items, 0, 0)
    .Cells(85, 6).Resize(obj1.Count, 5).Sort .Cells(85, 7), , .Cells(86, 8), , , , , 2
    .Cells(85, 6).Offset(obj1.Count + 1, 4) = Evaluate("sum(" & .Cells(85, 10).Address & ":" & .Cells(85 + obj1.Count, 10).Address & ")")
    .Cells(85, 12).Resize(obj2.Count, 5) = Application.Index(obj2.items, 0, 0)
    .Cells(85, 12).Resize(obj2.Count, 5).Sort .Cells(85, 13), , .Cells(86, 14), , , , , 2
    .Cells(85, 12).Offset(obj2.Count + 1, 4) = Evaluate("sum(" & .Cells(85, 16).Address & ":" & .Cells(85 + obj2.Count, 16).Address & ")")
    .Cells(85, 18).Resize(obj3.Count, 5) = Application.Index(obj3.items, 0, 0)
    .Cells(85, 18).Resize(obj3.Count, 5).Sort .Cells(85, 19), , .Cells(86, 20), , , , , 2
    .Cells(85, 18).Offset(obj3.Count + 1, 4) = Evaluate("sum(" & .Cells(85, 22).Address & ":" & .Cells(85 + obj3.Count, 22).Address & ")")
 End With
 End Sub
 
Harry dit is m!

Je bent echt geweldig.

Wil jou hartelijk bedanken voor jouw tijd en moeite.

Ik zal dit topic als opgelost zetten.

Met vriendelijke groet,

Roy
 
Gewoon de code kopiëren en plakken en aanpassen waar nodig.

Ik heb even naar de code gekeken en niets getest, en daar mis ik de stukjes in het blauw.
Code: 
 With Choose(sv(i, 1), obj1[COLOR=#0000ff], obj2, obj3[/COLOR])
 
Volgens mij haal je werkelijk alles door elkaar. Begin eerst bij het begin. Van zelfs de meest simpele formules weet je nog iets complex te maken. Heb je dit cel voor cel ingevoerd?
Code: 
=IF(SUM($D$2)*SUM($E$2)=0;"";SUM($D$2)*SUM($E$2))


Dit heeft geen enkel nut en daar komt de foutmelding ook niet vandaan:
Code: 
With Sheets("Algemeen").listobjects("tabel2")
 sv = Range("L2:AK393")

Dit stukje heb je blijkbaar ook niet begrepen
Code: 
With Choose(sv(i, 1), obj1, obj2, obj3)

Wat zal er gebeuren als sv(i,1) de waarde 2 krijgt met jouw aanpassing?
Code: 
With Choose(sv(i, 1), obj1)

Zeer hoogst waarschijnlijk fout 424.
 
Heren,

Het is gelukt met volgende code (moest nog wat kleine aanpassingen doen):

Code: 
 Sub Samenvatting_Verlichting()
Dim sv, a, b(4), i As Long, obj1 As Object, obj2 As Object, obj3 As Object
Set obj1 = CreateObject("scripting.dictionary")
Set obj2 = CreateObject("scripting.dictionary")
Set obj3 = CreateObject("scripting.dictionary")

With Blad2
 sv = .Range("L2:AK393")
     For i = 1 To UBound(sv)
      With Choose(sv(i, 1), obj1, obj2, obj3)
      
        If sv(i, 4) <> "" Then
          a = .Item(sv(i, 1) & sv(i, 4) & sv(i, 5))
               If IsEmpty(a) Then a = b
                 a(0) = sv(i, 1)
                 a(1) = sv(i, 4)
                 a(2) = sv(i, 5)
                 a(3) = a(3) + IIf(sv(i, 6) = "", 0, sv(i, 6))
                 a(4) = a(4) + IIf(sv(i, 8) = "", 0, sv(i, 8))
                 .Item(sv(i, 1) & sv(i, 4) & sv(i, 5)) = a
          End If
        
        If sv(i, 13) <> "" Then
             a = .Item(sv(i, 1) & sv(i, 13) & sv(i, 14))
               If IsEmpty(a) Then a = b
                 a(0) = sv(i, 1)
                 a(1) = sv(i, 13)
                 a(2) = sv(i, 14)
                 a(3) = a(3) + IIf(sv(i, 15) = "", 0, sv(i, 15))
                 a(4) = a(4) + IIf(sv(i, 17) = "", 0, sv(i, 17))
                .Item(sv(i, 1) & sv(i, 13) & sv(i, 14)) = a
            End If
        
        If sv(i, 22) <> "" Then
             a = .Item(sv(i, 1) & sv(i, 22) & sv(i, 23))
               If IsEmpty(a) Then a = b
                 a(0) = sv(i, 1)
                 a(1) = sv(i, 22)
                 a(2) = sv(i, 23)
                 a(3) = a(3) + IIf(sv(i, 24) = "", 0, sv(i, 24))
                 a(4) = a(4) + IIf(sv(i, 26) = "", 0, sv(i, 26))
                .Item(sv(i, 1) & sv(i, 22) & sv(i, 23)) = a
             End If
        End With
      Next i
    .Cells(396, 26).Resize(obj1.Count, 5) = Application.index(obj1.items, 0, 0)
    .Cells(396, 26).Resize(obj1.Count, 5).Sort .Cells(396, 27), , .Cells(397, 28), , , , , 2
    .Cells(396, 26).Offset(obj1.Count + 1, 4) = Evaluate("sum(" & .Cells(396, 30).Address & ":" & .Cells(396 + obj1.Count, 30).Address & ")")
    .Cells(396, 32).Resize(obj2.Count, 5) = Application.index(obj2.items, 0, 0)
    .Cells(396, 32).Resize(obj2.Count, 5).Sort .Cells(396, 33), , .Cells(397, 34), , , , , 2
    .Cells(396, 32).Offset(obj2.Count + 1, 4) = Evaluate("sum(" & .Cells(396, 36).Address & ":" & .Cells(396 + obj2.Count, 36).Address & ")")
    .Cells(396, 38).Resize(obj3.Count, 5) = Application.index(obj3.items, 0, 0)
    .Cells(396, 38).Resize(obj3.Count, 5).Sort .Cells(396, 39), , .Cells(397, 40), , , , , 2
    .Cells(396, 38).Offset(obj3.Count + 1, 4) = Evaluate("sum(" & .Cells(396, 42).Address & ":" & .Cells(396 + obj3.Count, 42).Address & ")")
 End With
 End Sub

Nog 2 dingen.

1. Indien ik een update wil doen van de samenvatting, zou ik graag dat de uitkomst van de vorige keer gewist wordt (range vanaf 396, 26 tot 397,42?). Hoe krijg ik dit voor elkaar?
2. Is het mogelijk om de totale optelling op 1 regel naast elkaar te krijgen ipv +1? Nu wordt bijv onder sector 1 de samenvatting gegeven en daarna 1 blanco regel en dan de totale som. Ik zou de totale som van alle 3 sectoren naast elkaar op 1 rij willen hebben.

Mvg

Roy.
 
Ik heb
Code: 
=IF(SUM($D$2)*SUM($E$2)=0;"";SUM($D$2)*SUM($E$2))
alleen op 1 regel aangemaakt en de rest is automatisch naar beneden gekopieerd in de tabel.
 
De code behoort niet meer bij het bestand uit je openingspost.
Plaats het bestand erbij waarin de code wel werkt.

In de formule kan je SUM en de haken weghalen.
Code: 
=if(D2*E2=0;"";D2*E2)
werkt evengoed.
 
Laatst bewerkt:
Met de aanpassingen.
Code: 
Sub Samenvatting_Verlichting()
Dim sv, a, b(4), i As Long, obj1 As Object, obj2 As Object, obj3 As Object
Set obj1 = CreateObject("scripting.dictionary")
Set obj2 = CreateObject("scripting.dictionary")
Set obj3 = CreateObject("scripting.dictionary")


With Blad2
 sv = .Range("L2:AK393")
     For i = 1 To UBound(sv)
      With Choose(sv(i, 1), obj1, obj2, obj3)
      
        If sv(i, 4) <> "" Then
          a = .Item(sv(i, 1) & sv(i, 4) & sv(i, 5))
               If IsEmpty(a) Then a = b
                 a(0) = sv(i, 1)
                 a(1) = sv(i, 4)
                 a(2) = sv(i, 5)
                 a(3) = a(3) + IIf(sv(i, 6) = "", 0, sv(i, 6))
                 a(4) = a(4) + IIf(sv(i, 8) = "", 0, sv(i, 8))
                 .Item(sv(i, 1) & sv(i, 4) & sv(i, 5)) = a
          End If
        
        If sv(i, 13) <> "" Then
             a = .Item(sv(i, 1) & sv(i, 13) & sv(i, 14))
               If IsEmpty(a) Then a = b
                 a(0) = sv(i, 1)
                 a(1) = sv(i, 13)
                 a(2) = sv(i, 14)
                 a(3) = a(3) + IIf(sv(i, 15) = "", 0, sv(i, 15))
                 a(4) = a(4) + IIf(sv(i, 17) = "", 0, sv(i, 17))
                .Item(sv(i, 1) & sv(i, 13) & sv(i, 14)) = a
            End If
        
        If sv(i, 22) <> "" Then
             a = .Item(sv(i, 1) & sv(i, 22) & sv(i, 23))
               If IsEmpty(a) Then a = b
                 a(0) = sv(i, 1)
                 a(1) = sv(i, 22)
                 a(2) = sv(i, 23)
                 a(3) = a(3) + IIf(sv(i, 24) = "", 0, sv(i, 24))
                 a(4) = a(4) + IIf(sv(i, 26) = "", 0, sv(i, 26))
                .Item(sv(i, 1) & sv(i, 22) & sv(i, 23)) = a
             End If
        End With
      Next i
      
aantal = Application.Max(obj1.Count, obj2.Count, obj3.Count)
 If aantal > 0 Then
    .Cells(396, 26).Resize(393, 17).ClearContents
   
    .Cells(396, 26).Resize(obj1.Count, 5) = Application.index(obj1.items, 0, 0)
    .Cells(396, 26).Resize(obj1.Count, 5).Sort .Cells(396, 27), , .Cells(397, 28), , , , , 2
    .Cells(396, 26).Offset(aantal + 1, 4) = Evaluate("sum(" & .Cells(396, 30).Address & ":" & .Cells(396 + obj1.Count, 30).Address & ")")
    .Cells(396, 32).Resize(obj2.Count, 5) = Application.index(obj2.items, 0, 0)
    .Cells(396, 32).Resize(obj2.Count, 5).Sort .Cells(396, 33), , .Cells(397, 34), , , , , 2
    .Cells(396, 32).Offset(aantal + 1, 4) = Evaluate("sum(" & .Cells(396, 36).Address & ":" & .Cells(396 + obj2.Count, 36).Address & ")")
    .Cells(396, 38).Resize(obj3.Count, 5) = Application.index(obj3.items, 0, 0)
    .Cells(396, 38).Resize(obj3.Count, 5).Sort .Cells(396, 39), , .Cells(397, 40), , , , , 2
    .Cells(396, 38).Offset(aantal + 1, 4) = Evaluate("sum(" & .Cells(396, 42).Address & ":" & .Cells(396 + obj3.Count, 42).Address & ")")
   End If
 End With
 End Sub
 
Harstikke bedankt Harry voor jouw tijd en moeite!

Het werkt nu perfect.

Met vriendelijke groet,

Roy.
 
Beste Harry,

Ik was even aan het testen met een bestaand project, echter gaat het op 1 punt niet goed.

Indien de sector alleen waarde "1" heeft (en dus geen 2 en 3), dan krijg ik een foutmelding en stopt de code (Fout 13 tijdens uitvoering: Typen komen niet met elkaar overeen).

Denk dat de code eerst moet kijken hoeveel sectoren er zijn en dan pas de code uitvoeren op basis van aantal sectoren? Kan dit aangepast worden aub?

Code: 
Sub Samenvatting_Verlichting()
Dim sv, a, b(4), i As Long, obj1 As Object, obj2 As Object, obj3 As Object
Dim wb As ThisWorkbook
Set obj1 = CreateObject("scripting.dictionary")
Set obj2 = CreateObject("scripting.dictionary")
Set obj3 = CreateObject("scripting.dictionary")
Set wb = ThisWorkbook

With Blad2
 sv = .Range("L2:AK393")
     For i = 1 To UBound(sv)
      With Choose(sv(i, 1), obj1, obj2, obj3)
      
        If sv(i, 4) <> "" Then
          a = .Item(sv(i, 1) & sv(i, 4) & sv(i, 5))
               If IsEmpty(a) Then a = b
                 a(0) = sv(i, 1)
                 a(1) = sv(i, 4)
                 a(2) = sv(i, 5)
                 a(3) = a(3) + IIf(sv(i, 6) = "", 0, sv(i, 6))
                 a(4) = a(4) + IIf(sv(i, 8) = "", 0, sv(i, 8))
                 .Item(sv(i, 1) & sv(i, 4) & sv(i, 5)) = a
          End If
        
        If sv(i, 13) <> "" Then
             a = .Item(sv(i, 1) & sv(i, 13) & sv(i, 14))
               If IsEmpty(a) Then a = b
                 a(0) = sv(i, 1)
                 a(1) = sv(i, 13)
                 a(2) = sv(i, 14)
                 a(3) = a(3) + IIf(sv(i, 15) = "", 0, sv(i, 15))
                 a(4) = a(4) + IIf(sv(i, 17) = "", 0, sv(i, 17))
                .Item(sv(i, 1) & sv(i, 13) & sv(i, 14)) = a
            End If
        
        If sv(i, 22) <> "" Then
             a = .Item(sv(i, 1) & sv(i, 22) & sv(i, 23))
               If IsEmpty(a) Then a = b
                 a(0) = sv(i, 1)
                 a(1) = sv(i, 22)
                 a(2) = sv(i, 23)
                 a(3) = a(3) + IIf(sv(i, 24) = "", 0, sv(i, 24))
                 a(4) = a(4) + IIf(sv(i, 26) = "", 0, sv(i, 26))
                .Item(sv(i, 1) & sv(i, 22) & sv(i, 23)) = a
             End If
        End With
      Next i
      
aantal = Application.Max(obj1.Count, obj2.Count, obj3.Count)
 If aantal > 0 Then
    .Cells(396, 26).Resize(393, 17).ClearContents
   
    .Cells(396, 26).Resize(obj1.Count, 5) = Application.index(obj1.items, 0, 0)
    .Cells(396, 26).Resize(obj1.Count, 5).Sort .Cells(396, 27), , .Cells(397, 28), , , , , 2
    .Cells(396, 26).Offset(aantal + 1, 4) = Evaluate("sum(" & .Cells(396, 30).Address & ":" & .Cells(396 + obj1.Count, 30).Address & ")")
    .Cells(396, 32).Resize(obj2.Count, 5) = Application.index(obj2.items, 0, 0)
    .Cells(396, 32).Resize(obj2.Count, 5).Sort .Cells(396, 33), , .Cells(397, 34), , , , , 2
    .Cells(396, 32).Offset(aantal + 1, 4) = Evaluate("sum(" & .Cells(396, 36).Address & ":" & .Cells(396 + obj2.Count, 36).Address & ")")
    .Cells(396, 38).Resize(obj3.Count, 5) = Application.index(obj3.items, 0, 0)
    .Cells(396, 38).Resize(obj3.Count, 5).Sort .Cells(396, 39), , .Cells(397, 40), , , , , 2
    .Cells(396, 38).Offset(aantal + 1, 4) = Evaluate("sum(" & .Cells(396, 42).Address & ":" & .Cells(396 + obj3.Count, 42).Address & ")")
   End If
 End With
 End Sub

Hoe gaat de code om indien er bijvoorbeeld 4 sectoren zijn? Moet hiervoor cases aangemaakt worden?

Met vriendelijke groet,

Roy
 
Kleine aanpassing voor de drie objecten.
Code: 
Sub Samenvatting_Verlichting()
Dim sv, a, b(4), i As Long, obj1 As Object, obj2 As Object, obj3 As Object
Set obj1 = CreateObject("scripting.dictionary")
Set obj2 = CreateObject("scripting.dictionary")
Set obj3 = CreateObject("scripting.dictionary")


With Blad2
 sv = .Range("L2:AK393")
     For i = 1 To UBound(sv)
      With Choose(sv(i, 1), obj1, obj2, obj3)
      
        If sv(i, 4) <> "" Then
          a = .Item(sv(i, 1) & sv(i, 4) & sv(i, 5))
               If IsEmpty(a) Then a = b
                 a(0) = sv(i, 1)
                 a(1) = sv(i, 4)
                 a(2) = sv(i, 5)
                 a(3) = a(3) + IIf(sv(i, 6) = "", 0, sv(i, 6))
                 a(4) = a(4) + IIf(sv(i, 8) = "", 0, sv(i, 8))
                 .Item(sv(i, 1) & sv(i, 4) & sv(i, 5)) = a
          End If
        
        If sv(i, 13) <> "" Then
             a = .Item(sv(i, 1) & sv(i, 13) & sv(i, 14))
               If IsEmpty(a) Then a = b
                 a(0) = sv(i, 1)
                 a(1) = sv(i, 13)
                 a(2) = sv(i, 14)
                 a(3) = a(3) + IIf(sv(i, 15) = "", 0, sv(i, 15))
                 a(4) = a(4) + IIf(sv(i, 17) = "", 0, sv(i, 17))
                .Item(sv(i, 1) & sv(i, 13) & sv(i, 14)) = a
            End If
        
        If sv(i, 22) <> "" Then
             a = .Item(sv(i, 1) & sv(i, 22) & sv(i, 23))
               If IsEmpty(a) Then a = b
                 a(0) = sv(i, 1)
                 a(1) = sv(i, 22)
                 a(2) = sv(i, 23)
                 a(3) = a(3) + IIf(sv(i, 24) = "", 0, sv(i, 24))
                 a(4) = a(4) + IIf(sv(i, 26) = "", 0, sv(i, 26))
                .Item(sv(i, 1) & sv(i, 22) & sv(i, 23)) = a
             End If
        End With
      Next i
      
aantal = Application.Max(obj1.Count, obj2.Count, obj3.Count)
 If aantal > 0 Then
    .Cells(396, 26).Resize(393, 17).ClearContents
  
 [COLOR=#0000ff] If obj1.Count > 0 Then[/COLOR]
      .Cells(396, 26).Resize(obj1.Count, 5) = Application.index(obj1.items, 0, 0)
      .Cells(396, 26).Resize(obj1.Count, 5).Sort .Cells(396, 27), , .Cells(397, 28), , , , , 2
      .Cells(396, 26).Offset(aantal + 1, 4) = Evaluate("sum(" & .Cells(396, 30).Address & ":" & .Cells(396 + obj1.Count, 30).Address & ")")
[COLOR=#0000ff]    End If[/COLOR]
    
[COLOR=#0000ff]    If obj2.Count > 0 Then[/COLOR]
      .Cells(396, 32).Resize(obj2.Count, 5) = Application.index(obj2.items, 0, 0)
      .Cells(396, 32).Resize(obj2.Count, 5).Sort .Cells(396, 33), , .Cells(397, 34), , , , , 2
      .Cells(396, 32).Offset(aantal + 1, 4) = Evaluate("sum(" & .Cells(396, 36).Address & ":" & .Cells(396 + obj2.Count, 36).Address & ")")
[COLOR=#0000ff]    End If[/COLOR]
    
[COLOR=#0000ff]    If obj3.Count > 0 Then[/COLOR]
      .Cells(396, 38).Resize(obj3.Count, 5) = Application.index(obj3.items, 0, 0)
      .Cells(396, 38).Resize(obj3.Count, 5).Sort .Cells(396, 39), , .Cells(397, 40), , , , , 2
      .Cells(396, 38).Offset(aantal + 1, 4) = Evaluate("sum(" & .Cells(396, 42).Address & ":" & .Cells(396 + obj3.Count, 42).Address & ")")
[COLOR=#0000ff]    End If[/COLOR]
   End If
 End With
 End Sub
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan