Selectie van namen samenvoegen

[Georgyboy]

Beste Helpmij,

Graag had ik een oplossing waar ik niet uitkom.

In voorbeeld een lijst Met aanwezige personen op datum, naam, afdeling en selectie.
Als de datum, afdeling en selectie overeen komen dan zou het fijn zijn de de namen in de in de laatste selectie na elkaar komen gescheiden door een komma.

Soms is het geen naam of 1 of meerdere namen.

Graag ook de namen tellen tussen de komma vb "VICKY CARETTE, Matthias CREVITS" zijn 2 namen

Bij voorbaat dank,
Georgyboy

 

[VenA]

Waarom geen draaitabel? Welke versie van Excel gebruik je? Mag het ook met VBA?

 

[Georgyboy]

Dank je VenA,

Heb dit ook geprobeerd met een draaitabel maar dan komen de namen onder elkaar

ERIC BAERT
Matthias CREVITS
PIETER BALLEGEER
VICKY CARETTE

Bedoeling is dat het zo komt op 1 rij: ERIC BAERT, Matthias CREVITS, PIETER BALLEGEER, VICKY CARETTE (dus telling in andere kolom indien mogelijk van 4 namen)
dit is voor het dan wissen van de lege bovenliggende rijen

Latere verweking in een andere tabel
Training 1 uur aan "ERIC BAERT, Matthias CREVITS, PIETER BALLEGEER, VICKY CARETTE" = 1 uur van trainer en totaal 4 uur van de geselecteerde deelnemers
Soms ook maar training aan 1 persoon vb 1 uur van trainer aan vb 1 deelnemer is elk 1 uur

Werk thuis op Helpmij met Excel 2019 en in de werkelijke tabel (werk) Excel 2010
Dus voor Excel 2010

Vba mag als het niet teveel gevraagd is? heb daar nog véél in te leren , maar tot nu toe met de code te kopiëren of een zéér kleine aanpassing lukt het wel.

alvast bedankt,
Georgyboy

 

[cow18]

zie bijlage, is voorlopig zonder gebruik te maken van tabellen, maar is zo aan te passen en uit te breiden.

 

[JEC.]

In het geel met office 365 formules.

 

[Georgyboy]

Bedankt cow18 werkt als een speer zoals sommigen zeggen
Hartelijk dank ook voor de info bij de code

Bedankt ook JVeer en VenA,
@ Jveer helaas heb ik geen office 365, wel nuttig te weten dat het zo ook kan :thumb:

@ cow18 Heb er vandaag al véél plezier aan beleefd, werkt in een flits

Groeten,
Georgyboy

 

[cow18]

leuk te horen !
Moet het geheel nog aangepast worden naar echte tabellen ?

 

[Georgyboy]

Bij voorbaat dank,
Georgyboy[/QUOTE]

 

[Georgyboy]

Beste Helpmij,

Graag had ik een oplossing waar ik niet uitkom.

In voorbeeld een lijst Met aanwezige personen op datum, naam, afdeling en selectie.
Als de datum, afdeling en selectie overeen komen dan zou het fijn zijn de de namen in de in de laatste selectie na elkaar komen gescheiden door een komma.

Soms is het geen naam of 1 of meerdere namen.

Graag ook de namen tellen tussen de komma vb "VICK CAR, Mat CREV" zijn 2 namen

Bij voorbaat dank,
Georgyboy

 

[VenA]

Gaat lekker zo.:d

 

[Georgyboy]

Goedemiddag,
Mag ik nog 1 vraag?

Bij het ingeven van gegevens in het echte bestand in de kolom “Afdeling” of “select”
Afdeling is tekst 10 tot 28 karakters Vb. 10. Afdeling AAA , alsook selectie “X”
Loopt het soms vast. Bestand is 5800 regels

Soms bij alle ingevulde regels in afdeling en dan +/- 160 selecties loopt het plots vast.
Bij ingave afdeling van 1 TM 5800 en bij select alles X lukt dit wel.

.Resize(dict.Count, 5).Value = Application.Index(dict.items, 0, 0)   'dictionary hier schrijven

Sub opsommen()
   Set dict = CreateObject("scripting.dictionary")                   'dictionary aanmaken
   arr = Sheets("Aanwezig").Range("A1").CurrentRegion                'gegevens lezen in array
   For r = 2 To UBound(arr)                                          'alle gegevens aflopen
      If Len(arr(r, 4)) > 0 Then                                     '4e kolom (selectie) is niet leeg
         s = CDbl(arr(r, 1)) & "|" & arr(r, 3) & "|" & arr(r, 4)     'sleutel datum & afdeling & selectie
         If Not dict.exists(s) Then                                  'sleutel nog niet gebruikt
            dict.Add s, Array(CLng(arr(r, 1)), arr(r, 3), arr(r, 4), arr(r, 2), 1)   'nieuwe key met gegevens aanmaken in dictionary
         Else
            a = dict(s)                                              'vorige input in de dictionary ophalen
            a(4) = a(4) + 1                                          'tellertje + 1
            a(3) = a(3) & ", " & arr(r, 2)                           'naam toevoegen
            dict(s) = a                                              'terugzetten in dictionary
         End If
      End If
   Next

   With Sheets("Aanwezig").Range("AA2")                              'outputbereik
      .CurrentRegion.Offset(1).ClearContents                         'leegmaken
      .Resize(dict.Count, 5).Value = Application.Index(dict.items, 0, 0)   'dictionary hier schrijven
      .Offset(, 2).EntireColumn.AutoFit                              'kolombreedte aanpassen
   End With
End Sub

alvast bedankt!

 

[cow18]

5.800 lijkt me niet spectaculair hoog om tegen de limieten aan te lopen.
Zie bijlage een dikke 1.200 Finn's en nog geen probleem, dan is die ene cel al 24.000 karakters lang. (max is 32.000 dacht ik, dus bij 1.600 Finn's zou ik in de problemen zitten.
Is dat realistisch ?

              a(3) = [COLOR="#FF0000"]Left([/COLOR]a(3) & ", " & arr(r, 2)[COLOR="#FF0000"], 32000)[/COLOR]                       'naam toevoegen [COLOR="#FF0000"]en beperken tot 32.000 karakters[/COLOR]

Voor die "x", ik kijk niet echt of het een x is, enkel of die kolom niet leeg is. Moet dat ?

 

[Georgyboy]

Dank Cow18,

Heb dit nog eens uitgeprobeerd.
Kolom A, B en C volledig ingevuld 5800 regels,
Bij aanvinken in kolom D (selectie) van enkele "X" loopt het goed, maar bij meerdere soms +/- 20 "X" of soms 100 en... loopt het vast op

.Resize(dict.Count, 5).Value = Application.Index(dict.items, 0, 0)   'dictionary hier schrijven

Kan op 1 of andere manier wel mijn plan trekken met knippen en plakken maar het is véél leuker met een klik op de knop

Alvast bedankt!

 

[cow18]

is dat ook met de bijlage van #12 ?
Maar je zegt anderszijds +/-20 of 100, dan zit het niet in die hoek van 32.000 !
Nu check ik werkelijk die "x", anders moet je me (privé) even die file sturen, er moet iets anders aan de hand zijn, iets geks in de kolom van je namen ???

 

[Georgyboy]

Net thuis geprobeerd en ging allemaal vlotjes, zelf met alle 5800 aangevinkt.

Probeer het anders nog eens op het werk met de gegevens van thuis bewerkt en doe even wat selecties weg en ze opnieuw invoegen.

Thuis heb ik Office 2019 en Excel 2019
Op het werk Office 2010 en Excel 2010

Wil ik het zo doen om morgen nog eens te proberen? anders stuur ik je de file vanavond nog door.

Groeten,
Georgyboy

 

[cow18]

ik heb Office 365, maar in principe, wat hier geschreven is, zou op beiden moeten werken.
Vermoedelijk liep je op 1 of andere manier tegen die 32.000 karakters-limiet aan, anders begrijp ik het niet.
5.800 records is peanuts

 

[VenA]

@cow18, loopt hier wel stuk in XL-2010 met of zonder .value

.ListRows.Add.Range.Range("A1").Resize(dict.Count, 5) = Application.Index(dict.items, 0, 0)   'dictionary hier schrijven

Runtime error 13 type mismatch. Verder geen onderzoek naar gedaan maar in XL-365 werkt het gewoon. Misschien toch ergens nog een limitatie waar we overheen gekeken/geen weet van hebben?

 

[cow18]

tja, dan kan ik geen deftig antwoord geven, wegens gebrek aan een XL-2010.
Als lapmiddel probeerde ik zonet de boel op te slaan als "xls" en het daarop te proberen.
Dat werkte wel foutloos.

Een gokje, als je hierboven in #12 de aanpassing ziet tot 32.000 karakters, zak dat eens onder de 255, bv. 250, werkt het dan ?

 

[cow18]

toch even snel de boel aangepast, zie bijlage
Als deze vlekkeloos loopt, dan kan je gaan spelen met die 250, maak die dan telkens factor 2 groter (500, 1000, 2000, ...)

If Len(a(3)) > [COLOR="#FF0000"]250[/COLOR] Then                               'lengte beperken tot net onder de 255 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
                  a(3) = Left(a(3), [COLOR="#FF0000"]250[/COLOR]) & "..."                     'naam toevoegen en beperken tot ... karakters
               End If

 

[Georgyboy]

Hartelijk dank !:thumb:
“Tes de puppe” 1 klik en alles getoverd naar wens.
1 kleine wens nog in de resultaat tabel hoeft de kolom selectie niet, maar kan het anders wel wissen.