Tabel & Dictionary

[Esducsafe]

@helpers

Met de macro kan een samenvatting uit een tabel (range “A1&E17”) worden gemaakt.

De range “A1&E17” wil ik wijzigen in A1&E10”

Zonder succes met meerdere opties (internet) geprobeerd de macro aan te passen,
zodat in de samenvatting alleen de gegevens uit de range A1&E10”
worden geteld en weergegeven.

Wie weet een oplossing?
Alvast bedankt.
Groet,
Esko van Hattem

Sub AA()
'overgenomen van Talisman
Dim rng As Range
Dim r As Range
Dim i As Integer
Dim j As Long
Dim n As Long
Dim txt As String
Dim ar As Variant
Dim arr As Variant

ActiveSheet.Columns("J:T").ClearContents

Set rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))

ar = [A1].CurrentRegion

    With CreateObject("scripting.dictionary")
        For Each r In rng
            txt = Join(Application.Transpose(Application.Transpose(r.Resize(, 2))), ",")
            If Not .Exists(txt) Then
                n = n + 1
                 .Add txt, n
                    For j = 1 To UBound(ar, 2)
                        ar(n, j) = r.Offset(, j - 1)
                    Next j
            Else
               For i = 3 To UBound(ar, 2)
                    ar(.Item(txt), i) = ar(.Item(txt), i) + r.Offset(, i - 1)
                Next i
            End If
        Next
        
     Sheets("Blad1").[L1].Resize(n, UBound(ar, 2)) = ar '     
    End With
End Sub

 

[snb]

Hiervoor heeft MS draaitabellen uitgevonden:

 

[Esducsafe]

@snb
Dank voor je reactie.
Draaitabellen zijn een optie, maar een oplossing in VBA heeft mijn voorkeur.
Groet,
Esko

 

[snb]

Onbegrijpelijk.

 

[Esducsafe]

Onbegrijpelijk of toch niet
.

 

[HSV]

Je kan toch wijzigen van:

Set rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))

naar..

set rng = range("a1:e10")

Hier nog twee methodes met de dictionary.

Sub hsv()
Dim sv, i As Long
sv = Range("a1:e10")
With CreateObject("scripting.dictionary")
 For i = 1 To UBound(sv)
 If Not .Exists(sv(i, 2)) Then
      .Item(sv(i, 2)) = Array(sv(i, 1), sv(i, 2), sv(i, 3), sv(i, 4), sv(i, 5))
     Else
      .Item(sv(i, 2)) = Array(sv(i, 1), sv(i, 2), .Item(sv(i, 2))(2) + sv(i, 3), .Item(sv(i, 2))(3) + sv(i, 4), .Item(sv(i, 2))(4) + sv(i, 5))
    End If
   Next
  Cells(1, 18).Resize(.Count, 5) = Application.Index(.Items, 0)
End With
End Sub

Sub hsv_2()
Dim sv, i As Long, a, b(4)
sv = Range("a1:e10")
 With CreateObject("scripting.dictionary")
   For i = 1 To UBound(sv)
    a = .Item(sv(i, 2))
     If IsEmpty(a) Then a = b
      a = .Item(sv(i, 2))
     If IsEmpty(a) Then a = b
        a(0) = sv(i, 1)
        a(1) = sv(i, 2)
        a(2) = a(2) + sv(i, 3)
        a(3) = a(3) + sv(i, 4)
        a(4) = a(4) + sv(i, 5)
     .Item(sv(i, 2)) = a
    Next i
  Cells(1, 18).Resize(.Count, 5) = Application.Index(.Items, 0)
End With
End Sub

 

[Esducsafe]

@HSV

Dank voor je bijdrage.

Set rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
naar..
set rng = range("a1:e10")
Deze aanpassing had ik zelf al gevonden, maar werkt dus niet.

Wel heb ik een oplossing kunnen uitwerken met “Sub hsv_2()”

Bij mijn vraag had ik niet vermeld, dat op basis van de range selectie
niet alleen het aantal rijen, maar ook het aantal kolommen kan variëren.
Om dit mogelijk te maken heb ik Sub hsv_2() als onderstaand aangepast.
De variabelen: Range rows en Columns worden via het script vastgesteld.
Met deze variabelen worden worden dan in de macro auto aangepast.
Voor het opheffen van fouten, als er meer of minder kolommen zijn
heb ik “On Error Resume Next” aan het script toegevoegd.
Mijn vraag: kan deze oplossing of is er nog een andere optie mogelijk?

Graag verneem ik je antwoord.
Groet,
Esko van Hattem

Sub hsv_2()

Dim sv, i As Long, a, b(6) 'cijfer = aantal Columns variabel
sv = Range("a1:F17")
 With CreateObject("scripting.dictionary")
   For i = 1 To UBound(sv)
    a = .Item(sv(i, 2))
     If IsEmpty(a) Then a = b
      a = .Item(sv(i, 2))
     If IsEmpty(a) Then a = b
        a(0) = sv(i, 1)
        a(1) = sv(i, 2)
        a(2) = a(2) + sv(i, 3)
        a(3) = a(3) + sv(i, 4)
        On Error Resume Next
        a(4) = a(4) + sv(i, 5)
        On Error Resume Next
        a(5) = a(5) + sv(i, 6)
     .Item(sv(i, 2)) = a
    Next i
  Cells(1, 12).Resize(.Count, 6) = Application.Index(.Items, 0)
End With
End Sub

 

[HSV]

Ik zie ineens ook dat je nieuwe tabel is gebaseerd op kolom A en B.

Sub hsv_2()
Dim sv, i As Long, a, j As Long
sv = Cells(1).CurrentRegion
 ReDim b(UBound(sv, 2)-1)
 With CreateObject("scripting.dictionary")
   For i = 1 To UBound(sv)
    a = .Item(sv(i, 1) & sv(i, 2))
     If IsEmpty(a) Then a = b
      a = .Item(sv(i, 1) & sv(i, 2))
     If IsEmpty(a) Then a = b
        a(0) = sv(i, 1)
        a(1) = sv(i, 2)
    For j = 2 To UBound(sv, 2) - 1
        a(j) = a(j) + sv(i, j + 1)
    Next j
     .Item(sv(i, 1) & sv(i, 2)) = a
    Next i
  Cells(1, 18).Resize(.Count, UBound(sv, 2)) = Application.Index(.Items, 0)
End With
End Sub