Meerdere dezelfde waarden in komol tellen als 1

[carloschouw]

Goedemorgen..!

Vraagje waar ik niet zo goed uit kom: is het mogelijk om meerdere dezelfde waarden op te tellen als 1? Voorbeeld:

In kolom A staat:

A
B
B
C
D
D
D

B b.v. komt 2x voor, D komt 3x voor,.. Nu moet b.v. D geen 3 weergeven maar aantal 1

In dit voorbeeld geef ik A, B, C, D aan maar de volgende keer is het b.v. G, H, T, AA, QSD,.. altijd verschillend, dus geen vaste waarden..

Is er een formule om dit te kunnen laten berekenen?

Groet, Carlo

 

[Cobbe]

Met deze formule haal je de unieke waarden uit bereik A2:A50:

=ALS.FOUT(INDEX(A$2:A$50;VERGELIJKEN(ONWAAR;ISGETAL(VERGELIJKEN(A$2:A$50;$D$1:D1;0));0));"")

Wel de formule invoeren via Ctrl Shft Enter want matrixformule
en doortrekken naar beneden zover als nodig

 

[carloschouw]

Thanks Cobbe..!

Het kan alleen met een matrixformule zeker? Mijn ervaring is nl dat wanneer je met een grote reeks matrixformules werkt het doorberekenen in Excel super langzaam gaat..

Wanneer het i.i.d. alleen met matrixformules werkt, misschien een mogelijkheid om dit soort zaken te berekenen via VBA?

 

[Cobbe]

Had dat dan gelijk gezegd.

Deze doet dat ook natuurlijk

Sub cobbe()
 Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Application.ScreenUpdating = False
 With Sheets("Blad1")
    For Each cl In .Cells(1).CurrentRegion.SpecialCells(2)
        If Not dic.exists(cl.Value) Then dic.Add cl.Value, Nothing
    Next cl
        .Columns(3).ClearContents
        .Cells(2, 3).Resize(dic.Count).Value = Application.Transpose(dic.keys)
 End With
End Sub

 

[popipipo]

Met een draaitabel is het ook eenvoudig op te lossen.

 

[carloschouw]

Yes..! SUPERRRRRRRRR

Top en bedankt voor je hulp!

 

[Cobbe]

Doe eens de test met deze:

Je gebruikt namelijk 2 x dezelfde dictionary:

Sub cobbe()
 Dim dic As Object
 Set dic1 = CreateObject("Scripting.Dictionary")
 Set dic2 = CreateObject("Scripting.Dictionary")
 Application.ScreenUpdating = False


With Sheets("Blad1")
  For Each cl In .Cells(1).CurrentRegion.SpecialCells(2)
   If Not dic1.exists(cl.Value) Then dic1.Add cl.Value, Nothing
  Next cl
    .Columns(3).ClearContents
    .Cells(2, 3).Resize(dic1.Count).Value = Application.Transpose(dic1.keys)
 End With

With Sheets("Blad2")
  For Each cl In .Cells(1).CurrentRegion.SpecialCells(2)
   If Not dic2.exists(cl.Value) Then dic2.Add cl.Value, Nothing
  Next cl
    .Columns(3).ClearContents
    .Cells(2, 3).Resize(dic2.Count).Value = Application.Transpose(dic2.keys)
 End With
 Application.ScreenUpdating = True
End Sub

 

[carloschouw]

Heej? Mijn vraagstelling is verdwenen?

Vraagstelling was: Hoe krijg ik de waarde van Blad2 ook werkend? Nu neemt hij de waarde van Blad1 over in Blad2,..

@cobbe

Het werkt! Hoe krijg ik het werken voor meerdere bladen? Wanneer ik b.v.

Sub cobbe()
Dim dic As Object
Set dic1 = CreateObject("Scripting.Dictionary")
Set dic2 = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False


With Sheets("Blad1")
For Each cl In .Cells(1).CurrentRegion.SpecialCells(2)
If Not dic1.exists(cl.Value) Then dic1.Add cl.Value, Nothing
Next cl
.Columns(3).ClearContents
.Cells(2, 3).Resize(dic1.Count).Value = Application.Transpose(dic1.keys)
End With

With Sheets("Blad2")
For Each cl In .Cells(1).CurrentRegion.SpecialCells(2)
If Not dic2.exists(cl.Value) Then dic2.Add cl.Value, Nothing
Next cl
.Columns(3).ClearContents
.Cells(2, 3).Resize(dic2.Count).Value = Application.Transpose(dic2.keys)
End With
Application.ScreenUpdating = True
End Sub

verander in:

Sub cobbe()
Dim dic As Object
Set dic1 = CreateObject("Scripting.Dictionary")
Set dic2 = CreateObject("Scripting.Dictionary")
Set dic3 = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False


With Sheets("Blad1")
For Each cl In .Cells(1).CurrentRegion.SpecialCells(2)
If Not dic1.exists(cl.Value) Then dic1.Add cl.Value, Nothing
Next cl
.Columns(3).ClearContents
.Cells(2, 3).Resize(dic1.Count).Value = Application.Transpose(dic1.keys)
End With

With Sheets("Blad2")
For Each cl In .Cells(1).CurrentRegion.SpecialCells(2)
If Not dic2.exists(cl.Value) Then dic2.Add cl.Value, Nothing
Next cl
.Columns(3).ClearContents
.Cells(2, 3).Resize(dic2.Count).Value = Application.Transpose(dic2.keys)
End With

With Sheets("Blad3")
For Each cl In .Cells(1).CurrentRegion.SpecialCells(2)
If Not dic3.exists(cl.Value) Then dic3.Add cl.Value, Nothing
Next cl
.Columns(3).ClearContents
.Cells(2, 3).Resize(dic3.Count).Value = Application.Transpose(dic2.keys)
End With

Application.ScreenUpdating = True
End Sub

Neemt hij de waarde van Blad3 niet mee maar van Blad2

 

[carloschouw]

Heej? Mijn vraagstelling is verdwenen?

Vraagstelling was: Hoe krijg ik de waarde van Blad2 ook werkend? Nu neemt hij de waarde van Blad1 over in Blad2,..

@cobbe

Het werkt! Hoe krijg ik het werken voor meerdere bladen? Wanneer ik b.v.



verander in:



Neemt hij de waarde van Blad3 niet mee maar van Blad2

Ik zie de fout al:

.Cells(2, 3).Resize(dic3.Count).Value = Application.Transpose(dic2.keys)

Moet zijn

.Cells(2, 3).Resize(dic3.Count).Value = Application.Transpose(dic3.keys)

Het werkt perfect!!!! Helemaal top