Help!

PC-Problemen?
De vrijwilligers van Oplossing.be zoeken gratis met u mee!

Hulp bij posten

Recente topics

Auteur Topic: Verhinderen van 2 maal zelde code  (gelezen 846 keer)

0 leden en 1 gast bekijken dit topic.

Offline rdcoster

  • Ervaren lid
  • ***
  • Berichten: 274
  • Geslacht: Man
  • Oplossing.be
Verhinderen van 2 maal zelde code
« Gepost op: 25 juli 2022, 13:57:32 »
Beste oplossers,

In een poging om vanuit een Excel bestand een GEDCOM-bestand (voor stamboomprogramma's) te genereren loop ik vast op het 2 maal creëren van een partner-relatie.
De relatie-ID staat in kolom J en zegt welke personen bij elkaar horen; dus er staat een getal bij een man en hetzelfde getal bij een vrouw. (bijv. 1348646203 op rij 2 samen met rij 9 vormen een koppel).

In de Gedcom moet dit getoond worden als:
0 @F1348646203@ FAM
1 HUSB @I428@
1 WIFE @I81@

waarin I428 en I81 de RIN-nummers (kolom A) zijn van de betrokkenen.

Nu komt het:
Ik doorloop mijn macro van rij naar rij, maar dan wordt bovenstaande code 2 maal gegenereerd.
Zie in de macro naar comment "DEZE CODE MAG SLECHTS 1 KEER WEERGEGEVEN WORDEN PER RELATIE".

Hoe kan ik dit oplossen ?

Mvg René

Windows 10
Excel 2013

Offline RedHead

  • Excel-Expert
  • Ambassadeur
  • *****
  • Berichten: 2.277
  • Geslacht: Man
  • Met Excel lukt 't wel.... (toch???)
Re: Verhinderen van 2 maal zelde code
« Reactie #1 Gepost op: 25 juli 2022, 22:07:15 »
rdcoster, ik denk dat deze toevoeging van een Dictionary je wel gaat helpen....

Sub GEDCOM_test()
Dim FileName As String
    Dim NumRows As Long
    Dim NumCols As Integer
    Dim r As Long
    Dim c As Integer
   
    Dim TempDict As Object
    Set TempDict = CreateObject("scripting.dictionary")
   
Open "C:\leo.txt" For Output As #1
'Open "C:\Users\Rene\Documents\Gedcomtest.ged" For Output As #1
' Print Header
Print #1, "0 HEAD"
Print #1, "1 SOUR REDECO"
Print #1, "2 VERS 1.1"
Print #1, "1 DATE 22 JUL 2022"
Print #1, "2 TIME 07:44:12"
Print #1, "1 SUBM @SUBM1@"
Print #1, "1 GEDC"
Print #1, "2 VERS 5.5"
Print #1, "2 FORM Lineage-Linked"
Print #1, "1 CHAR UTF-8"

Range("A1").Select
Selection.End(xlDown).Select
NumRows = Range("A1").End(xlDown).Row

For r = 2 To NumRows
    Data = "0 @I" & Range("A" & r).Value & "@ INDI"
    Print #1, Data
 '   Data = "1 RIN " & Range("A" & r).Value
 '   Print #1, Data
    Data = "1 NAME " & Range("C" & r).Value & "/" & Range("B" & r).Value & "/"
    Print #1, Data
    Data = "1 SEX " & Range("F" & r).Value
    Print #1, Data
    Data = "1 BIRT"
    Print #1, Data
    Data = "2 DATE " & Range("G" & r).Value
    Print #1, Data
    Data = "2 PLAC " & Range("H" & r).Value
    Print #1, Data
    Data = "1 FAMS @F" & Range("J" & r).Value & "@"
    Print #1, Data
line1: a = a
Next r

' Family construction
   
    For r = 2 To NumRows
    relatieID = Range("J" & r).Value
   
    If relatieID <> 0 Then
        If Not TempDict.exists(relatieID) Then
            TempDict(relatieID) = ""
                Data = "0 @F" & relatieID & "@ FAM" ' DEZE CODE MAG SLECHTS 1 KEER WEERGEGEVEN WORDEN PER RELATIE
                Print #1, Data
               
            ' Search Partner
                Partner = relatieID
                For rowrel = 2 To NumRows
                If Partner = Range("J" & rowrel).Value And Range("F" & rowrel).Value = "M" Then
                    Data = "1 HUSB @I" & Range("A" & rowrel).Value & "@"
                    Print #1, Data
                    Debug.Print relatieID
                End If
                Next rowrel
           
                For rowrel = 2 To NumRows
                If Partner = Range("J" & rowrel).Value And Range("F" & rowrel).Value = "F" Then
                    Data = "1 WIFE @I" & Range("A" & rowrel).Value & "@"
                    Print #1, Data
                End If
                Next rowrel
                End If
           
        ' Get Marriage info
            If Range("K" & r).Value <> 0 Then
                Data = "1 MARR"
                Print #1, Data
                Data = "2 DATE " & Range("K" & r).Value
                Print #1, Data
            End If
            If Range("L" & r).Value <> 0 Then
                Data = "2 PLAC " & Range("L" & r).Value
                Print #1, Data
            End If
         ' Get Children info
            Dim ChildArray() As String
            Children = Range("P" & r).Value
            If Children <> 0 Then
                ChildArray() = Split(Children)
                U = UBound(ChildArray())
                For i = 0 To U
                    Data = "1 CHIL @I" & ChildArray(i) & "@"
                    Print #1, Data
                Next i
            End If
        End If
   
    Next r


    Data = "0 TRLR"
    Print #1, Data
Close #1
End Sub
Vergeet niet om je outputpad en bestand weer even naar die van jezelf terug te zetten. En haal daarnaast ook die vervuiling (voor je test gok ik) van het immediate window in de VBE er uit. Anders loopt de boel ongenadig vol. ;)
______________________________

Groet, Leo

Offline rdcoster

  • Ervaren lid
  • ***
  • Berichten: 274
  • Geslacht: Man
  • Oplossing.be
Re: Verhinderen van 2 maal zelde code
« Reactie #2 Gepost op: 27 juli 2022, 07:07:39 »
Leo,
Uw oplossing werkt (al begrijp ik de constructie van de 'Directionary' nog niet goed).

Wel nog een andere vraag (of moet dit in een apart topic):
Als je in een VBA-macro verwijst naar bepaalde cellen met de Range of de Cells instructie dan ben je wel gebonden dat er niets in de Worksheet verandert.
Bijv. als je een kolom invoegt gaat de macro niet meer correct werken.

Is dit op te lossen?
Windows 10
Excel 2013

Offline RedHead

  • Excel-Expert
  • Ambassadeur
  • *****
  • Berichten: 2.277
  • Geslacht: Man
  • Met Excel lukt 't wel.... (toch???)
Re: Verhinderen van 2 maal zelde code
« Reactie #3 Gepost op: 27 juli 2022, 08:28:47 »
Rdcoster, fijn dat de oplossing werkt. Een handige eigenschap van de Dictionary is de Exists methode. Een dictionary bestaat uit unieke Keys. Door met een nieuwe entry te controleren of dat al een Key is die bestaat, kan je dus snel tests uitvoeren. Zo dus...
Mbt je andere vraag... leer werken met Named Ranges en met Tables. Die kan je vanuit VBA code heel gestructureerd aanroepen.
______________________________

Groet, Leo

Offline rdcoster

  • Ervaren lid
  • ***
  • Berichten: 274
  • Geslacht: Man
  • Oplossing.be
Re: Verhinderen van 2 maal zelde code
« Reactie #4 Gepost op: 30 juli 2022, 06:40:04 »
Ik heb mij een beetje verdiept in Named Ranges en Tables en zou volgende code gebruiken om bijv. de 4de waarde van kolom 'Voornamen' te vinden.
Nu kan ik ook kolommen invoegen zonder dat de code moet aangepast worden.
(zie bijlage)
Misschien kan de instructie korter ??

Mvg
René
Windows 10
Excel 2013

Offline MollyVH

  • Excel-Expert
  • Oplosser
  • *****
  • Berichten: 847
Re: Verhinderen van 2 maal zelde code
« Reactie #5 Gepost op: 30 juli 2022, 11:39:23 »
Dag René,

In je commentaar heb je al staan "assumes Table is the first one on the ActiveSheet". Dat geeft op zich al aan dat je jezelf ook in de nesten kan werken. Beter kan je helemaal op veilig spelen door namen te gebruiken, al dan niet in combinatie met "Set".
In feite zou dit bv. dus al kunnen volstaan:
Sub test()
naam = Worksheets("personen").ListObjects("Tabel_1").ListColumns("Voornamen").DataBodyRange(4)
End Sub

Mvg,
Molly
Windows 11 Home NLD 64bit
11th Gen Intel(R) Core(TM) i7-11700 @ 2.50GHz 2496
Aspire TC-1660
Intel(R) UHD Graphics 750 1024MB
476 GB SSD KINGSTON OM8PCP3512F-AA
1863 GB HD Seagate ST2000DM008-2FR102
Office 2021 Professional Plus NLD 64bit

 


www.combell.com