Zoeken met meerdere resultaten

[rv82]

Ik heb een vraag over het opzoeken van meerdere resultaten en deze in 1 cel tonen als samenvatting.

In het voorbeeldbestand heb ik een fictieve casus opgenomen. Wat ik graag wil, is dat (in dit geval) alle informatie van Klas B1 in 1 cel wordt weergegeven. Hierbij moet het type communicatie van toepassing zijn op Klas B1 en moet daarbij ook worden aangegeven voor welke groep dit type communicatie geldt....het type communicatie dan het liefst tussen haakjes tonen tbv leesbaarheid.

Beetje een raar voorbeeld misschien, maar het gaat om het idee.

 

[AlexCEL]

Zoiets voor B12:

=TEKST.COMBINEREN(", ";WAAR;ALS(ISGETAL(VIND.SPEC("B1";$C$3:$C$6));$A$3:$A$6&" ("&$B$3:$B$6&")";""))

Wel office 365 vereist.

 

[rv82]

Dank je....en zonder Office365?

 

[JEC.]

=tekst.samenvoegen(a3&"("&b3&"), ";a4&"("&b4&"), ";a5&"("&b5&"), ";a6&"("&b6&")")

 

[rv82]

=tekst.samenvoegen(a3&"("&b3&"), ";a4&"("&b4&"), ";a5&"("&b5&"), ";a6&"("&b6&")")

Dit voegt alleen de tekst samen, dus lijkt wel een deel van de formule te zijn. Alleen voegt dit alle tekst samen...dus ook "Anders" terwijl B1 geen waarde heeft in de categorie "Anders".

 

[JEC.]

Je hebt helemaal gelijk. Ik heb het bestand geopend zonder de vraag te lezen

 

[rv82]

Je hebt helemaal gelijk. Ik heb het bestand geopend zonder de vraag te lezen

Geeft niet...ik waardeer de moeite om te helpen al enorm!

 

[AlexCEL]

Kan wel, maar dan wordt de formule wel een stuk minder elegant...

=SUBSTITUEREN(SUBSTITUEREN(ALS(ISGETAL(VIND.SPEC("B1";C3));A3&" ("&B3&"), ";"")&ALS(ISGETAL(VIND.SPEC("B1";C4));A4&" ("&B4&"), ";"")&ALS(ISGETAL(VIND.SPEC("B1";C5));A5&" ("&B5&"), ";"")&ALS(ISGETAL(VIND.SPEC("B1";C6));A6&" ("&B6&")";"")&"^^";", ^^";"");"^^";"")

 

[rv82]

Kan wel, maar dan wordt de formule wel een stuk minder elegant...

=SUBSTITUEREN(SUBSTITUEREN(ALS(ISGETAL(VIND.SPEC("B1";C3));A3&" ("&B3&"), ";"")&ALS(ISGETAL(VIND.SPEC("B1";C4));A4&" ("&B4&"), ";"")&ALS(ISGETAL(VIND.SPEC("B1";C5));A5&" ("&B5&"), ";"")&ALS(ISGETAL(VIND.SPEC("B1";C6));A6&" ("&B6&")";"")&"^^";", ^^";"");"^^";"")

Ja, ik zie wat je bedoelt. Het werkt inderdaad op dit kleine voorbeeldje wel. Maar als de lijst van kolom A langer wordt (in mijn werkelijke bestand zijn dit 35 items), dan wordt de formule wel heel lang.
Het is niet mogelijk om met een matrix-achtige constructie te werken zodat Excel dezelfde excercitie per rij herhaalt binnen een bepaald bereik (bv rij 3 t/m 38)?

 

[VenA]

Dan maar met een macro

Sub VenA()
  Dim j As Long, jj As Long, ar, x
  ar = Cells(2, 1).CurrentRegion 'zet alle gegevens vanaf A2 in een array
  Set d = CreateObject("Scripting.Dictionary") 'maak een dictionary aan
  For j = 2 To UBound(ar) 'doorloop alle rijen in de variabele ar
    x = Split(Replace(ar(j, 3), " ", ""), ",") 'Splits de klassen in de 3e kolom van ar op ", ")
    For jj = 0 To UBound(x) 'doorloop de klassen
      If d.Exists(x(jj)) Then 'als een klas bestaat in de dictionary dan
        c00 = d(x(jj)) & ar(j, 1) & " (" & ar(j, 2) & ") " 'voeg de eerder gegevens samen met de 1e en 2e kolom van ar
        d(x(jj)) = c00 'schrijf de nieuwe gegevens naar de dictionary
       Else 'anders
        d(x(jj)) = ar(j, 1) & " (" & ar(j, 2) & " ) " 'maak een nieuwe sleutel en vul deze met de 1e en 2e kolom van ar
      End If
    Next jj 'volgende klas in x
  Next j 'volgende rij in ar
  Cells(1, 10).Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items)) 'schrijf de gegevens weg
End Sub

 

[rv82]

Dan maar met een macro

Sub VenA()
  Dim j As Long, jj As Long, ar, x
  ar = Cells(2, 1).CurrentRegion
  Set d = CreateObject("Scripting.Dictionary")
  For j = 2 To UBound(ar)
    x = Split(Replace(ar(j, 3), " ", ""), ",")
    For jj = 0 To UBound(x)
      If d.Exists(x(jj)) Then
        c00 = d(x(jj)) & ar(j, 1) & " (" & ar(j, 2) & ") "
        d(x(jj)) = c00
       Else
        d(x(jj)) = ar(j, 1) & " (" & ar(j, 2) & " ) "
      End If
    Next jj
  Next j
  Cells(1, 10).Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))
End Sub

Thanks! Dit werkt.
Alleen snap ik totaal niet hoe ik de verschillende variabelen kan herkennen. En dus lukt het me ook niet om het te vertalen naar mijn live-bestand.
Zou je me daarmee op weg kunnen helpen door de variabelen toe te lichten? Dank je!

 

[VenA]

Je hoeft geen hele berichten te quoten. Dat maakt het er alleen maar onleesbaar op. het bericht in #10 heb ik van commentaar voorzien. Hoewel je ook met <F8> door code kan lopen om te zien welke variabele welke waarde krijgt. Al is een dictionary lastig te debuggen

 

[rv82]

Dan quote ik niet :d

Ik krijg de foutmelding "Typen komen niet overeen".
Bij het echte bestand staan de gegevens "Post, Telefoon" etc in A46 t/m A74. De zoekwaarde (referentie waarnaar gezocht moet worden) staat in E46 t/m E74 en de gegevens die tussen haakjes moeten komen (vergelijkbaar met "Ouder, Kind") staan in C46 t/m E74. Ik heb er dus van gemaakt:

Sub VenA()
Dim j As Long, jj As Long, ar, x
ar = Cells(46, 1).CurrentRegion 'zet alle gegevens vanaf A2 in een array
Set d = CreateObject("Scripting.Dictionary") 'maak een dictionary aan
For j = 2 To UBound(ar) 'doorloop alle rijen in de variabele ar
x = Split(Replace(ar(j, 5), " ", ""), ",") 'Splits de klassen in de 3e kolom van ar op ", ")
For jj = 0 To UBound(x) 'doorloop de klassen
If d.Exists(x(jj)) Then 'als een klas bestaat in de dictionary dan
c00 = d(x(jj)) & ar(j, 1) & " (" & ar(j, 3) & ") " 'voeg de eerder gegevens samen met de 1e en 2e kolom van ar
d(x(jj)) = c00 'schrijf de nieuwe gegevens naar de dictionary
Else 'anders
d(x(jj)) = ar(j, 1) & " (" & ar(j, 3) & " ) " 'maak een nieuwe sleutel en vul deze met de 1e en 2e kolom van ar
End If
Next jj 'volgende klas in x
Next j 'volgende rij in ar
Cells(1, 10).Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items)) 'schrijf de gegevens weg
End Sub


En als dat werkt zit ik nog met het issue dat de Currentregion en de doelcel op verschillende tabbladen staan. Al kan ik daar wel omheen werken indien noodzakelijk (maar liever niet :d)

En oh ja, super merci voor de hulp! Echt top!

 

[VenA]

Maar nu vergeet je het gebruik van codetags waardoor het een onleesbare brei aan code en commentaar geworden is. En is het nu opgelost of niet? Anders maar een representatief voorbeeld plaatsen. Lees ook dit even door. https://www.helpmij.nl/forum/announcement.php?f=5

Sheets("Resultaatblad").Cells(1).Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items)) 'schrijf de gegevens weg naar het blad 'Resultaatblad' te beginnen in A1

 

[AlexCEL]

Met een verborgen hulpkolom kom ik er ook.

 

[rv82]

Dank! Het voorbeeld met de hulpkolom werkt 100% EN snap ik (niet onbelangrijk, haha). Ik markeer m als opgelost. Nogmaals dank voor alle suggesties en feedback.