Output naar enkele woorden icm som van data reeksen

[smitty2016]

Goedemorgen,

Ik ben op zoek naar een manier om uit een lijst met tekst (één of meerdere woorden per cel) gecombineerd met 2 datasets een overzicht te maken waarin per enkel woord de som van de datasets wordt getoond.
Heb een voorbeeld bestand als bijlage meegestuurd, hierin een voorbeeld van brondata en de gewenste output.

Is dit überhaupt mogelijk met excel?

Alvast bedankt voor het meedenken.

Groeten,

Smitty

Bekijk bijlage Map1.xlsx

 

[AlexCEL]

Voor C11:

=SOMPRODUCT(ISGETAL(VIND.SPEC($B11;$B$4:$B$8))*C$4:C$8)

Doortrekken naar rechts en naar onderen en voilà, het gewenste resultaat.

 

[smitty2016]

Hi Alexcel,

Dank voor je snelle reactie, dat helpt me al aardig op weg.
De enkele woorden moeten echter ook uit het bronbestand (kolom b , rij 4 t/m 8) gehaald worden automatisch.
Het gaat om lijsten met meer dan 5000 regels, dat wil ik graag automatisch laten doen.

Groeten,

Smitty

 

[AlexCEL]

Denk dat daar een VBA oplossing voor nodig is. Niet mijn expertise helaas, maar genoeg overige specialisten hier.

Lijkt me wel lastig trouwens... is "e bike" bijvoorbeeld 1 woord? Hoe ga je om met meervoudsvormen (review/reviews, 1 woord of 2?).

 

[smitty2016]

Zeker een lastig verhaal idd.. Hoop op de VBA experts dan. E bike zijn dan twee aparte woorden evenals review en reviews, spatie is leading dus.

 

[VenA]

Als de spatie leading is dan klopt de 'Gewenste output' in het bestand niet. e bike spel je net als e-mail met een koppelteken.

 

[smitty2016]

Scherp gezien, maar denk dat het idee duidelijk is Heb je een oplossing voor dit vraagstuk?

 

[VenA]

Als de data begint in A1 kan je zoiets proberen.

Sub VenA()
With Blad1.Cells(1).CurrentRegion
    .Replace "e bike", "e-bike"
    ar = .Value
    For j = 2 To UBound(ar)
        t = t + Len(ar(j, 1)) - Len(Replace(ar(j, 1), " ", "")) + 1
    Next j
    ReDim ar1(t - 1, 2)
    For j = 2 To UBound(ar)
        For jj = 0 To UBound(Split(ar(j, 1)))
            ar1(t1, 0) = Split(ar(j, 1))(jj)
            ar1(t1, 1) = ar(j, 2)
            ar1(t1, 2) = ar(j, 3)
            t1 = t1 + 1
        Next
    Next
End With
With Blad2.Cells(1)
    .Resize(, 3) = Array("tekst", "data1", "data2")
    .Offset(1).Resize(UBound(ar1) + 1, 3) = ar1
End With
End Sub

Een draaitabel eroverheen en klaar

 

[Ginger]

@V&A, slim om de zinnen alleen maar uit elkaar te trekken en er daarna een pivot overheen te gooien. Werkt als een speer en je hoeft niet moeilijk te doen met je procedure om te kijken of je woord al aanwezig is en die dan op te gaan tellen (al komt hier vast weer een mooi Dict voorbeeld overheen ).

 

[VenA]

al komt hier vast weer een mooi Dict voorbeeld overheen

Hoop ik ook op. Ik denk dat we hetzelfde 'probleem' hebben. (Iets van wel begrijpen maar niet snappen of wel snappen maar niet begrijpen:d)

 

[HSV]

Sub hsv()
Dim sn, sq, i As Long, ii As Long, dic
sn = Blad1.Cells(1).CurrentRegion
With CreateObject("scripting.dictionary")
 Set dic = CreateObject("scripting.dictionary")
 For i = 2 To UBound(sn)
   sq = Split(sn(i, 1))
       For ii = 0 To UBound(sq)
         .Item(sq(ii)) = .Item(sq(ii)) + sn(i, 2)
      dic.Item(sq(ii)) = dic.Item(sq(ii)) + sn(i, 3)
       Next ii
   Next i
Blad2.Cells(1).Resize(.Count, 3) = Application.Transpose(Array(.keys, .items, dic.items))
End With
End Sub

 

[smitty2016]

@VenA: Top, dat werkt erg mooi. Idd draaitabel erop en done!
@HSV: Die krijg ik niet aan de praat, ligt aan mijn beperkte ervaringen met dit soort codes :-(

Iig dank, ik ga er mee aan de slag!

 

[VenA]

Mooi dat het opgelost is.

Het is altijd prettig als bepaalde code niet werkt of niet aan de praat te krijgen is om er dan bij te vermelden wat er fout gaat. De code van HSV werkt perfect op het voorbeeldbestandje en scheelt dus een extra handeling om er een draaitabel van te maken. In de code in #8 stond een foutje waardoor de laatste waarde niet weggeschreven werd.

.Offset(1).Resize(UBound(ar1) [COLOR="#FF0000"]+ 1[/COLOR], 3) = ar1

 

[smitty2016]

@VenA: Toch nog ff wat pogingen gedaan met de code van @HSV. Die doet het nu ook. Gaat idd nog een stuk makkelijker zonder de draaitabel,

Thnx again!

 

[smitty2016]

@HSV: Kun je me nog aangeven welke aanpassing in de code moet ik doen als ik in het bronbestand nog een kolom met data toevoeg (data3 in kolom D)?

 

[HSV]

Ik zou met lussen kunnen werken wat waarschijnlijk mee tijd in beslag neemt: dus maar een extra 'Set' is net zo gemakkelijk.

Sub hsv()
Dim sn, sq, i As Long, ii As Long, dic as object,oDic as object
sn = Blad1.Cells(1).CurrentRegion
With CreateObject("scripting.dictionary")
 Set dic = CreateObject("scripting.dictionary")
 Set odic = CreateObject("scripting.dictionary")
 For i = 2 To UBound(sn)
   sq = Split(sn(i, 1))
       For ii = 0 To UBound(sq)
         .Item(sq(ii)) = .Item(sq(ii)) + sn(i, 2)
      dic.Item(sq(ii)) = dic.Item(sq(ii)) + sn(i, 3)
      odic.Item(sq(ii)) = odic.Item(sq(ii)) + sn(i, 4)
       Next ii
   Next i
Blad2.Cells(1).Resize(.Count, 3) = Application.Transpose(Array(.keys, .items, dic.items,odic.items))
End With
End Sub