Samenvatting maken uit meerdere tabellen VBA

Status
Niet open voor verdere reacties.
Beste SNB,

Ik heb de draaitabel gecheckt. Op zich werkt dit wel goed op basis van 1 set verlichting.

Kan de draaitabel gemaakt worden op basis mijn eerste voorbeeld (zie template bij mijn eerste regel).
Nu is de draaitabel gemaakt op basis van 1 set verlichting (onder elkaar).
Ik heb namelijk 3 sets verlichting (3 naast elkaar).

Mvg

Roy
 
Lees svp mijn berichten nog eens goed.
Je mag natuurlijk zelf ook iets doen met aangereikte suggesties.
Als je mijn suggestie begrijpt ben je ineens een stuk verder.
 
Ik heb het ook geprobeerd om 3 aparte draaitabellen te maken, echter moet ik alsnog handmatig het totale vermogen optellen. Echter kan dit ook met een formule opgelost worden.
Ik probeerde alle 3 sets verlichting als 1 draaitabel te maken, echter wordt dit onoverzichtelijk doordat er teveel kolommen in de draaitabel staan.
Is het niet mogelijk om een draaitabel te maken, waarbij 1x soort verlichting en type verlichting wordt getoond? Nu krijg ik verlichting 1, verlichting 2, verlichting 3, soort 1, soort 2 etc in de kolommen te zien.
Anders zou ik dit toch met de code van HSV moeten oplossen.

Mvg.
Roy
 
Laatst bewerkt door een moderator:
@HSV:

Ik heb de code ook aangepast naar 10 sectoren.

Ik heb nog 1 probleem.
Indien ik de code gebruik, dan is de totaaloptelling soms vreemd. Ik krijg soms nullen te zien als totaaloptelling bij de diverse sectoren of andere waarden en bij sommige sectoren is te totaalopteling wel goed. Indien ik de code wederom gebruik, dan staat de totale som wel goed.

Indien ik weer een type lamp aanpas en vervolgens weer de code gebruik, dan krijg ik weer hetzelfde probleem en moet ik dan voor de 2e keer de code gebruiken om het goed te krijgen.

Waar gaat dit mis?

Code: 
Sub Samenvatting(control As IRibbonControl)
 'Samenvatting verlichting
 
Dim sv, a, b(10), i As Long, obj1 As Object, obj2 As Object, obj3 As Object, obj4 As Object, obj5 As Object, obj6 As Object, obj7 As Object, obj8 As Object, obj9 As Object, obj10 As Object
Dim wb As ThisWorkbook

Set obj1 = CreateObject("scripting.dictionary")
Set obj2 = CreateObject("scripting.dictionary")
Set obj3 = CreateObject("scripting.dictionary")
Set obj4 = CreateObject("scripting.dictionary")
Set obj5 = CreateObject("scripting.dictionary")
Set obj6 = CreateObject("scripting.dictionary")
Set obj7 = CreateObject("scripting.dictionary")
Set obj8 = CreateObject("scripting.dictionary")
Set obj9 = CreateObject("scripting.dictionary")
Set obj10 = CreateObject("scripting.dictionary")

Set wb = ThisWorkbook


With wb.Sheets("algemeen")
 sv = .Range("L2:AL393")
     For i = 1 To UBound(sv)
      With Choose(sv(i, 1), obj1, obj2, obj3, obj4, obj5, obj6, obj7, obj8, obj9, obj10)
      
        If sv(i, 4) <> "" Then
          a = .Item(sv(i, 1) & sv(i, 4) & sv(i, 5) & sv(i, 7) & sv(i, 9))
               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))
                 a(5) = sv(i, 9)
                 .Item(sv(i, 1) & sv(i, 4) & sv(i, 5) & sv(i, 7) & sv(i, 9)) = a
          End If
        
        If sv(i, 13) <> "" Then
             a = .Item(sv(i, 1) & sv(i, 13) & sv(i, 14) & sv(i, 16) & sv(i, 18))
               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))
                 a(5) = sv(i, 18)
                 .Item(sv(i, 1) & sv(i, 13) & sv(i, 14) & sv(i, 16) & sv(i, 18)) = a
          End If
        
        If sv(i, 22) <> "" Then
             a = .Item(sv(i, 1) & sv(i, 22) & sv(i, 23) & sv(i, 25) & sv(i, 27))
               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))
                 a(5) = sv(i, 27)
                .Item(sv(i, 1) & sv(i, 22) & sv(i, 23) & sv(i, 25) & sv(i, 27)) = a
             End If
        End With
      Next i
      
aantal = Application.Max(obj1.Count, obj2.Count, obj3.Count)
 If aantal > 0 Then
  With Sheets("samenvatting")
    .UsedRange.ClearContents
   
    
    If obj1.Count > 0 Then
      .Cells(2, 1).Resize(obj1.Count, 10) = Application.index(obj1.items, 0, 0)
      .Cells(2, 1).Resize(obj1.Count, 10).Sort .Cells(2, 2), , .Cells(2, 3), , , , , 2
      .Cells(2, 1).Offset(aantal + 1, 4) = Evaluate("sum(" & .Cells(2, 5).Address & ":" & .Cells(2 + obj1.Count, 5).Address & ")")
    End If
    
    If obj2.Count > 0 Then
      .Cells(2, 8).Resize(obj2.Count, 10) = Application.index(obj2.items, 0, 0)
      .Cells(2, 8).Resize(obj2.Count, 10).Sort .Cells(2, 8), , .Cells(2, 9), , , , , 2
      .Cells(2, 8).Offset(aantal + 1, 4) = Evaluate("sum(" & .Cells(2, 12).Address & ":" & .Cells(2 + obj2.Count, 12).Address & ")")
    End If
    
    If obj3.Count > 0 Then
      .Cells(2, 15).Resize(obj3.Count, 10) = Application.index(obj3.items, 0, 0)
      .Cells(2, 15).Resize(obj3.Count, 10).Sort .Cells(2, 15), , .Cells(2, 16), , , , , 2
      .Cells(2, 15).Offset(aantal + 1, 4) = Evaluate("sum(" & .Cells(2, 19).Address & ":" & .Cells(2 + obj3.Count, 19).Address & ")")
    End If
    
    If obj4.Count > 0 Then
      .Cells(2, 22).Resize(obj4.Count, 10) = Application.index(obj4.items, 0, 0)
      .Cells(2, 22).Resize(obj4.Count, 10).Sort .Cells(2, 22), , .Cells(2, 23), , , , , 2
      .Cells(2, 22).Offset(aantal + 1, 4) = Evaluate("sum(" & .Cells(2, 26).Address & ":" & .Cells(2 + obj4.Count, 26).Address & ")")
    End If
    
    If obj5.Count > 0 Then
      .Cells(2, 29).Resize(obj5.Count, 10) = Application.index(obj5.items, 0, 0)
      .Cells(2, 29).Resize(obj5.Count, 10).Sort .Cells(2, 29), , .Cells(2, 30), , , , , 2
      .Cells(2, 29).Offset(aantal + 1, 4) = Evaluate("sum(" & .Cells(2, 33).Address & ":" & .Cells(2 + obj5.Count, 33).Address & ")")
    End If
    
    If obj6.Count > 0 Then
      .Cells(2, 36).Resize(obj6.Count, 10) = Application.index(obj6.items, 0, 0)
      .Cells(2, 36).Resize(obj6.Count, 10).Sort .Cells(2, 36), , .Cells(2, 37), , , , , 2
      .Cells(2, 36).Offset(aantal + 1, 4) = Evaluate("sum(" & .Cells(2, 40).Address & ":" & .Cells(2 + obj6.Count, 40).Address & ")")
      End If
      
    If obj7.Count > 0 Then
      .Cells(2, 43).Resize(obj7.Count, 10) = Application.index(obj7.items, 0, 0)
      .Cells(2, 43).Resize(obj7.Count, 10).Sort .Cells(2, 43), , .Cells(2, 44), , , , , 2
      .Cells(2, 43).Offset(aantal + 1, 4) = Evaluate("sum(" & .Cells(2, 47).Address & ":" & .Cells(2 + obj7.Count, 47).Address & ")")
      End If
      
    If obj8.Count > 0 Then
      .Cells(2, 50).Resize(obj8.Count, 10) = Application.index(obj8.items, 0, 0)
      .Cells(2, 50).Resize(obj8.Count, 10).Sort .Cells(2, 50), , .Cells(2, 51), , , , , 2
      .Cells(2, 50).Offset(aantal + 1, 4) = Evaluate("sum(" & .Cells(2, 54).Address & ":" & .Cells(2 + obj8.Count, 54).Address & ")")
      End If
      
    If obj9.Count > 0 Then
      .Cells(2, 57).Resize(obj9.Count, 10) = Application.index(obj9.items, 0, 0)
      .Cells(2, 57).Resize(obj9.Count, 10).Sort .Cells(2, 57), , .Cells(2, 58), , , , , 2
      .Cells(2, 57).Offset(aantal + 1, 4) = Evaluate("sum(" & .Cells(2, 61).Address & ":" & .Cells(2 + obj9.Count, 61).Address & ")")
      End If
      
    If obj10.Count > 0 Then
      .Cells(2, 64).Resize(obj10.Count, 10) = Application.index(obj10.items, 0, 0)
      .Cells(2, 64).Resize(obj10.Count, 10).Sort .Cells(2, 64), , .Cells(2, 65), , , , , 2
      .Cells(2, 64).Offset(aantal + 1, 4) = Evaluate("sum(" & .Cells(2, 68).Address & ":" & .Cells(2 + obj10.Count, 68).Address & ")")
      End If
     
 End With
  End If
 End With
 Application.EnableEvents = True
 
 End Sub

Mvg
Roy.
 
Laatst bewerkt:
Die..
...code zou ik vergeten, en terug naar een van de eerste codes die ik heb geschreven.
...was er voor om twee extra lussen te omzeilen.
...is nu niet meer interessant.

Plaats het bestand nog eens met de veranderingen.
 
Laatst bewerkt:
Bijgaand het bestand.
 

Bijlagen

  • Test_template140119.xlsm
    171,9 KB · Weergaven: 26
Laatst bewerkt door een moderator:
@royb73

Kun je even vertellen op welke manier je deze bijlage hebt toegevoegd ?
 
Via paperclip - toevoegen - uploaden - bestand geselecteerd en dan gereed.
Alleen dit keer ging hij niet in 1x goed. Moest 2e keer op paperclip klikken en zag in Hyperlink het bestand staan en heb toen erop geklikt.

Ik zie bij bijlage "Bijlage 333835" staan als hyperlink, terwijl het bestand "Test_template140119.xlsm" heet??
 
Met welke browser werk je ?

En kun je een schermafbeelding plaatsen van wat je ziet als je op het paperclipicoon hebt geklikt ?
 
Laatst bewerkt:
Ik werk met Google Chrome (altijd al).

test.jpg
 

Bijlagen

  • Test_template140119 (1).xlsm
    171,9 KB · Weergaven: 25
Snap niet waarom de XLS is toegevoegd. In eerste instantie stond er niks. Heb toen weer op paperclip geklikt en printscreen gemaakt.
Na het toevoegen van jpg bestand en reactie plaatsen, stond ook opeens de XLS bestand???
Heb vaker XLS bestanden geupload en hier geplaasts, maar nooit problemen mee gehad.
 
Code werkt prima voor mij. Alleen heb ik het probleem dat ik 2x de code moet runnen om de juiste optelling te krijgen. 1e keer krijg ik dus niet het juiste optelling. Pas bij de 2e keer.

Mvg
Roy
 
Laatst bewerkt door een moderator:
@HSV:

Code: 
 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

Waarom staat hier onder If " a = .Item(sv(i, 1) & sv(i, 13) & sv(i, 14))" en boven End If ".Item(sv(i, 1) & sv(i, 13) & sv(i, 14)) = a"? Is dit niet hetzelfde?
 
Dat kan, maar door de veranderingen in onderstaande...

Code: 
 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))
...krijgt array (a) een andere waarde en daarmee de .item(sv(i...... ook.
 
na heel vluchtig gelezen te hebben, ik weet niet, maar waarom geen (moeder)dictionary gebruiken met daarin als elementen die dictionaries zoals hierboven.
Dan ben je vrij in het aantal bouwlagen, 1, 10, 100, 1000, ... ?
Vind het nogal complex gemaakt.
 
na heel vluchtig gelezen te hebben, ik weet niet, maar waarom geen (moeder)dictionary gebruiken met daarin als elementen die dictionaries zoals hierboven.
Dan ben je vrij in het aantal bouwlagen, 1, 10, 100, 1000, ... ?
Vind het nogal complex gemaakt.

Kan je anders eens een moeilijk geval (10 lagen) als voorbeeld hier neer zetten.
Laatste voorbeeld in #47 (dacht ik) is vrij simpel nog.
Moest je die 10 tabellen daarna samenvoegen tot 1 summarytabel, dan kan je daar netjes een draaitabel uit maken, zonder die tig dictionaries.

Ik heb niet alles gelezen, misschien zie ik iets over het hoofd.
 
Laatst bewerkt:
Dat is het met al die dictionary's inderdaad @cow18.

Het begon met een dictionary en drie lussen.
Om de snelheid er een beetje in te houden heb ik die twee lussen omgezet naar twee extra dictionary's.

We hebben al wat voorstellen gedaan maar het veranderd steeds of er wordt niet op gereageerd.
Ook schreef ik dat het niet de manier is om met al die dictionary's te werken.

Ik ben wel bereid het een en ander in elkaar te maken, maar niet als het alsmaar veranderd.
Ik laat het er maar bij zodat ik de tijd beter kan investeren in een aantal andere vragen.
 
Beste Harry / COW18.

Ik had verleden keer al een bestand toegevoegd, maar kreeg geen reactie meer. Volgens mij ging er toen ook iets niet goed met het toevoegen van de bijlage (zie bericht SNB).

Ook mijn excuses dat het soms lang duurde voordat ik een antwoord gaf. Ik had een paar dingen zelf opgelost of moest op antwoord wachten van de adviseurs.

Bijgaand het Excel blad.
 

Bijlagen

  • Rekenbestand.xlsm
    193,1 KB · Weergaven: 22
zie vanaf regel 50 van algemeen en dan de samenvatting.
Waarom moet je hier explicit alle variabelen in de Dim zetten ?
Waarom werkt een gewone left hier niet ?

Macro "verzamelen", alleen kende ik de exacte vraag niet, dus is het een beetje een gok
 

Bijlagen

  • Rekenbestand (1).xlsm
    196,8 KB · Weergaven: 26
Laatst bewerkt:
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan