Gegevens uit 2 tabbladen combineren/extraheren

[jansm]

Beste allemaal,
In de tabbladen [Personen] en [Feiten] staan gegevens die ik in tabblad [Verzamel] wil combineren.
Het betreft persoonsgegevens. Iedere persoon heeft een uniek persoonsnummer dat vermeld staat in de kolommen A van tabblad [Personen] en[ Feiten]. Sommige personen komen op beide tabbladen 1 of meerdere keren voor. Als een persoon een partner heeft dan komt deze persoon in [Personen] 2 keer voor. Heeft hij/zij 2 partners gehad dan komt hij 4 x voor enz. De tabel is gesorteerd op persoonsnummer dus als hij/zij gehuwd zijn en dus vaker voorkomen dan zullen dat opeenvolgende rijnummers zijn.
Wat wil ik graag bereiken? De bedoeling is dat ik bepaalde regels uit [Personen] en de gegevens uit de laatste kolom van [Feiten] wil combineren in [Verzamelen].
Komt een persoon in [Personen] 1x voor dan wil ik de betreffende rij gekopieerd hebben in [Verzamel].
Heeft hij/zij een partner, dus vaker 2x voorkomt, dan wil ik de eerste rij waarin hij/zij genoemd wordt negeren en de 2e rij kopieren naar [Verzamel].
Heeft hij/zij 2 partners gehad dan komt hij/zij dus op 4 achtereenvolgende rijen voor. Dan wil ik dus de 1e en 3e rij waarop hij/zij voorkomt negeren en de 2e en 4e rij kopieren naar [Verzamel].
Sommige personen hebben 1 of meerdere aliassen. Deze staan in de laatste kolom van [Feiten]. In dit tabblad kolom A staan weer de unieke persoonsnummers die corresponderen met de persoonsnummers in [Personen] en [Verzamel]. Van alle regels in [Feiten] wil ik de gegevens in laatste kolom S-Opmerking kopieren naar [Verzamel], en dan wel onder de betreffende regel en dan in Kolom E –Achternaam.
In de bijlage staat in tabblad [Verzamel] het resultaat zoals het zou moeten worden. Ik hoop dat iemand dit probleem voor mij kan oplossen. Ben reuze benieuwd
Mvg, Jansm
Bekijk bijlage HelpMij_Test.xlsm

 

[jansm]

goedenavond heren,
wil er geen oplossing voor mijn probleem of is er een andere reden?
Mvg, Jans

 

[Cobbe]

Ja we zijn kwaad op u. !!

 

[popipipo]

We zijn allemaal vrijwilligers en hebben meestal wel wat anders te doen tussen 12 uur 's nachts en 7 uur 's avonds

Ik ga zo even je echte vraag lezen geen idee waar het lange verhaal over gaat.
En dus ook geen idee of ik een antwoord weet en of je nog van me hoort.
Alvast succes

 

[jansm]

Weledele Mega Honourable Senior Member Cobbe, wat kan ik voor u doen om het weer goed te maken?

 

[Cobbe]

Niet meer zo'n moeilijke vragen stellen.

 

[jansm]

.....dacht dat jullie wel op een uitdaging zitten te wachten.
Zonder gekheid: zou het fijn vinden als er door een van jullie een oplossing gevonden wordt.

 

[snb]

In Excel 2010

Lint / data / remove duplicates/ velden: intern_nr, eerste, partner

 

[jansm]

dank snb.
En nu de 2e vraag: gegevens van [Feiten] naar [Verzamel].
Kan dit ook in VBA geschreven worden?

 

[WHER]

Test eens of volgende macro ongeveer doet wat je voor ogen had, klik de button op sheet "Test".
Ik heb je gegevens op de sheet "Personen" wel enigzins ingekort voor de overzichtelijkheid.

 

[jansm]

Hallo Wher, bedankt voor jouw werk (en ook HSV een beetje!). Er wordt gedaan wat ik graag wil. Alleen moeten alle kolommen van [Personen] mee naar [Test]. Als ik een poging doe om de code een beetje te lezen dan is het nogal wat als kolom A t/m AJ mee moet. Is dat wel te doen zo?
Mvg, jansm

 

[WHER]

Dit is gewoon een kwestie van de Array uit te breiden:

 Odic.Item(sn(i, 1) & sn(i, 9)) = Array(sn(i, 1), sn(i, 2), sn(i, 3), sn(i, 4), sn(i, 5), sn(i, 6), sn(i, 7), sn(i, 8), sn(i, 9), sn(i, 10))

Dus aanvullen met "sn(i, 11), sn(i, 12), etc... tot je alle gewenste kolommen mee hebt.
Vervolgens de Resize aanpassen op beide plaatsen:

 Sheets("Test").Cells(2, 1).Resize(Odic.Count, 10)

de 10 dus vervangen door het aantal elementen van de Array

 

[snb]

HSV's code gemaltraiteerd:

Sub M_snb()
  sn = Sheets("Personen").Cells(1).CurrentRegion
  sp = Sheets("Feiten").Cells(1, 1).CurrentRegion
  
  With CreateObject("scripting.dictionary")
    For j = 1 To UBound(sn)
      .Item(sn(i, 1) & sn(i, 9)) = Application.Index(sn, j)
    Next
    Sheets("Test").Cells(2, 1).Resize(.Count, UBound(sn, 2)) = Application.Index(.items, 0, 0)
  End With
    
  On Error Resume Next
  With Sheets("Test")
      .Cells(1).CurrentRegion.Sort .Cells(1), , , , , , , 1
      For j = 1 To UBound(sp)
         .Columns(1).Find(sp(j, 1)).Offset(1).EntireRow.Insert
       Next
   End With
End Sub

 

[jansm]

Hallo Snb, jij ook bedankt. Maar ik krijg een foutmelding. Kan zelf de oorzaak niet vinden.

 

[jansm]

Snb, ik heb de tellers i en j veranderd. Dan geen foutmelding maar nu worden de aliassen uit [Feiten] niet in kolom E van de de lege regels geplaatst .

Sub M_snb()
sn = Sheets("Personen").Cells(1).CurrentRegion
sp = Sheets("Feiten").Cells(1, 1).CurrentRegion
With CreateObject("scripting.dictionary")
For i = 1 To UBound(sn)
.Item(sn(i, 1) & sn(i, 9)) = Application.Index(sn, i)
Next
Sheets("Test").Cells(2, 1).Resize(.Count, UBound(sn, 2)) = Application.Index(.items, 0, 0)
End With
On Error Resume Next
With Sheets("Test")
.Cells(1).CurrentRegion.Sort .Cells(1), , , , , , , 1
For j = 1 To UBound(sp)
.Columns(1).Find(sp(j, 1)).Offset(1).EntireRow.Insert
Next
End With
End Sub

 

[jansm]

Hallo WHER, het werkt zoals jij zegt. Zou het nog mogelijk zijn om 1 voorwaarde in te bouwen en wel voor het kopieren van de alias uit [Feiten]? De voorwaarde zou dan moeten zijn dat in [Feiten] in kolom S "ALIAS" moet staan. Dan moet de inhoud van kolom S overgenomen worden. Ik heb geprobeerd om het tabblad [Feiten] te filteren op Alias maar dat werkt niet.

 

[WHER]

dat in [Feiten] in kolom S "ALIAS" moet staan.

Bedoel je niet kolom R van tabblad "Feiten"?
In het voorbeeldbestand staat in elke rij van kolom R het woord "ALIAS", dus daar valt niets te filteren?

 

[jansm]

je hebt gelijk, ik bedoel R.
De oorspronkelijke file bevat >5000 regels en ik heb voor de voorbeeldfile een selectie gemaakt. En dom genoeg, met alleen de waarde 'ALIAS' in R. Dus mijn vraag blijft eigenlijk staan. Deze bijlage bevat wel andere waarden in kolom R-[Feiten]. Je moet dan geen regels weggooien voor het testen zoals je bij de eerste bijlage hebt gedaan. Ik hoop dat het je lukt.

Bekijk bijlage HelpMij_Test2.xlsm

 

[snb]

Als je de aangereikte code analyseert en begrijpt kun je hem daartoe aanpassen.
Dat is voor jou evenveel werk als voor WHER.

 

[WHER]

Toch maar even (beide) codes aangepast, ze zouden nu een soortgelijk resultaat moeten geven.