Tabel als resultaat zonder draaitabel/subtotalen

[woltersgert]

Geacht forum,

ik zoek een oplossing voor de volgende uitdaging:

er moet een samenvattingstabel komen die records gaat samenvoegen en optellen etc. op basis van een uniek nummer.

het bestand is bijgevoegd, de uitleg is tekstueel veel te lang, vandaar. In het Excel document Bekijk bijlage Lijst.xlsx is het erg overzichtelijk.

de enige oplossing mag gemaakt worden met Excel zelf en/of i.c.m. Vba. Geen omwegen via bijvoorbeeld Access o.i.d.
Nogmaals, Excel en of Excel Vba.

Het resultaat is van belang, welke Excel oplossing evt. met Vba maakt ons niet uit. Als het er maar uit komt te zien zoals in het voorbeeld document.
Indien het met Vba moet zien we graag de code tegemoet, indien mogelijk.

Met vriendelijke groet,

GW

 

[HSV]

Zet deze code in een module.
Verwijder de rijen in blad "Lijst" die als voorbeeld dienen (vanaf rij 18 dus).
Maak een extra blad aan genaamd "Blad1" (zonder de dubbele quotes uiteraard).
Roep de code eens aan met Alt+F5, en kijk op blad1 voor het resultaat.

Sub hsv()
Dim LRij As Long, i As Long, ii As Long, n As Long, j As Long
Dim arS, arr
Dim Sstring As String, verzameltekst As String
With Sheets("Lijst")
  LRij = .Cells(.Rows.Count, 1).End(xlUp).Row - 1
  arS = .Cells(2, 1).Resize(LRij, 6).Value
ReDim arr(LRij * LRij, 6)
For i = 1 To LRij
  verzameltekst = Join(Array(arS(i, 1), arS(i, 2), arS(i, 3)))
  If InStr(Sstring, verzameltekst & "|") = 0 Then
For ii = 1 To LRij
 If Join(Array(arS(ii, 1), arS(ii, 2), arS(ii, 3))) = verzameltekst Then
    For j = 0 To 5
        If j < 5 Then
              arr(n, j) = arS(i, j + 1)
            Else
              arr(n, j) = arr(n, j) + arS(i, j + 1)
            End If
         Next j
      Sstring = Sstring & verzameltekst & "|"
    End If
 Next ii
     n = n + 1
       End If
     Next i
    End With
With Sheets("Blad1").Range("A1")
    .CurrentRegion.ClearContents
    .Resize(, 6) = Split(Join(Application.Index(Sheets("Lijst").Range("a1").Resize(, 6).Value, 1, 0), "|"), "|")
    .Offset(1).Resize(n - 1, 6) = arr
  End With
End Sub

 

[snb]

Is dit een opdracht tegen betaling ?

 

[HSV]

Moet ik de gegeven code verwijderen, of mijn banknummer plaatsen?

 

[snb]

Ik vind de vragensteller zulke voorwaarden stellen dat het redelijk is dat hij je eerst een aanbetaling doet.
Ik ben ook wel benieuwd voor welk bedrijf dit is.

 

[Elsendoorn2134]

GW,

In je bestand staat een tabel, ik stel voor dat je er gebruik van maakt.
Kopieer de eerst drie kolommen naar een ander tabblad, bij voorbeeld "Blad1" en laat de
dubbele waarden uit deze kolom verwijderen, je houd dan vanzelf de zeven regels over die
je hebben wilt.

In een VBA code komt dit neer op:

Sub MaakLijst()
    
    Sheets("Lijst").Range("Table5[[#All],[Abonnement]:[Nummer          ]]").Copy _
        Destination:=Worksheets("Blad1").Range("A1")
    Sheets("Blad1").Range("$A$1", Range("$C$1").End(xlDown)).RemoveDuplicates Columns:=Array(1, 2, 3), _
        Header:=xlYes
End Sub

Vervolgens heb je de optelling van de waarden nog nodig maar daar is een formule voor die gebruik kan maken van de
tabel die je al gedefinieerd hebt.

Voor telling van bedrag:

=SOMMEN.ALS(Table5[Bedrag];Table5[Abonnement];Blad1!$A2;Table5[Gebruikersnaam];Blad1!$B2;Table5[[Nummer          ]];Blad1!$C2)

Voor de telling van de duur en de frequentie hoef je alleen de tekst "Bedrag" in de formule te wijzigen in "Duur" of "Frequentie".

Veel Succes.

 

[pixcel]

Maak een draaitabel.

 

[woltersgert]

Vraag voor HSV

Super, dank voor de code.

Indien mogelijk heb ik nog 2 wensen:

Wens1:
Indien abonnement, gebruikersnaam en nummer gelijk zijn, wordt de frequentie keurig opgeteld.
Zou dit ook kunnen voor de kolom Bedrag en de kolom Duur, waarvoor dezelfde voorwaarde geldt?

Wens2:
Indien er unieke rijen worden toegevoegd, dan neemt de Vba code deze nog niet mee. Hoe kan ik dit veranderen?

Met vriendelijke groet,

GW

 

[snb]

Het is toch nog geen Sinterklaas ?

 

[HSV]

Ik heb er niet zoveel problemen mee hoor.
Wel twee dingetjes:
1: Stel je bescheiden op (dus geen "moet" in de vraagstelling).
2: Stel je vraag niet expliciet aan iemand.

Je wil immers geholpen worden, en door wie maakt je niet uit toch?

De code aangepast.

Sub hsv()
Dim LRij As Long, i As Long, ii As Long, n As Long
Dim arS, arr
Dim Sstring As String, verzameltekst As String
With Sheets("Lijst")
 LRij = .Cells(.Rows.Count, 1).End(xlUp).Row
  arS = .Cells(1, 1).Resize(LRij + 1, 6).Value
ReDim arr(LRij * LRij, 6)
For i = 2 To LRij
         verzameltekst = Join(Array(arS(i, 1), arS(i, 2), arS(i, 3), arS(i, 4), arS(i, 5)))
If InStr(Sstring, verzameltekst & "|") = 0 Then
For ii = i To LRij
 If Join(Array(arS(ii, 1), arS(ii, 2), arS(ii, 3), arS(ii, 4), arS(ii, 5))) = verzameltekst Then
             arr(n, 0) = arS(ii, 1)
             arr(n, 1) = arS(ii, 2)
             arr(n, 2) = arS(ii, 3)
             arr(n, 3) = arS(ii, 4)
             arr(n, 4) = arS(ii, 5)
             arr(n, 5) = arr(n, 5) + arS(ii, 6)
         End If
     Next ii
                     n = n + 1
      Sstring = Sstring & verzameltekst & "|"
        End If
     Next i
    End With
With Sheets("Blad1").Range("A1")
    .CurrentRegion.ClearContents
    .Resize(, 6) = Split(Join(Application.Index(Sheets("Lijst").Range("a1").Resize(, 6).Value, 1, 0), "|"), "|")
    .Offset(1).Resize(n, 6) = arr
  End With
End Sub