'************************************************************ '* NBRSearch Version 1.0 * '* Written January 2003 by W. Wesley Johnston * '* Non-blood Relationship Search of a GEDCOM File: Find all * '* relationships (blood or non-blood) between two people. * '************************************************************ '********************************************************************************* '* Instructions: * '* You must first create a worksheet titled "Report Results" in your Excel file. * '* 1. In the line below, enter the RINs for the two people: XPerson and YPerson. * '* 2. In the next line, enter the full-path GEDCOM File name: GEDCOMFile. * '* 3. To run the search, click within the Sub NBRSearch() section, * '* and then select RUN from the menu at the top. * '********************************************************************************* Const XPerson = 1, YPerson = 134 ' 12901 is a non-match with 1 in ccc ' Karen Lowe is 11784 Const GEDCOMFile = "c:/ccc.ged" '************************************** '* Globally define all the needed variables, '* constants and arrays. '* '* The critical element for fast lookups is being able to '* use an index-value lookup in an array. '************************************** Const RINLimit = 100000, MRINLimit = 50000, FPLimit = 30, PFLimit = 10 Const LevelLimit = 1000, TupleLimit = 1000 Const X = 1, Y = 2 Dim RinFlag(1 To 2, 1 To RINLimit) As Boolean ' Cell Value is TRUE or FALSE Dim RinName(1 To RINLimit) As String ' Cell Value is the Person's name Dim NRINS As Long ' Count of the number of RINs in the file Dim MAXRIN As Long ' The highest RIN number in the file Dim Rin As Long Dim MRin As Long Dim Role As Boolean ' MRinExpanded tells whether a given MRin has been expanded by X or Y or both. Dim MRinExpanded(1 To 2, 1 To MRINLimit) As Boolean ' FamPers (or just FP) uses a family MRIN to find all members' RINs Dim FamPers(1 To MRINLimit, 1 To FPLimit) As Long ' Cell Value is a +/- RIN ' PersFam (of just PF) uses a person's RIN to find all MRINs to which he/she belongs Dim PersFam(1 To RINLimit, 1 To PFLimit) As Long ' Cell Value is +/- MRIN ' + = Spouse (i.e., if +MRin or +Rin, then person is a spouse in that MRin) ' - = Child (i.e., if -MRin or -Rin, then person is a child in that MRin) Dim NMRINS As Long ' Count of the number of MRINs in the file Dim MAXMRIN As Long ' The highest MRIN number in the file ' Define the Expansion Quintuples ' Role is FALSE if Child and TRUE if Parent Dim Mrin1(1 To 2, 1 To LevelLimit, 1 To TupleLimit) As Long ' Value is the Expansion Generating MRin Dim Role1(1 To 2, 1 To LevelLimit, 1 To TupleLimit) As Boolean ' Value is the Expansion Generating Role Dim XRin(1 To 2, 1 To LevelLimit, 1 To TupleLimit) As Long ' Value is the Expansion Rin Dim Mrin2(1 To 2, 1 To LevelLimit, 1 To TupleLimit) As Long ' Value is the Expansion Generated MRin Dim Role2(1 To 2, 1 To LevelLimit, 1 To TupleLimit) As Boolean ' Value is the Expansion Generated Role '************************************* '* I will search the individual tuples within a level to follow '* the trail back for display. Since this is only done a few times, '* the slowness of the unindexed search will not be that much of a factor '* to require creating and building inversion indices for the tuples. '************************************* Dim ExpansionStep As Integer Dim UnableToExpandLevel As Boolean Dim SideToExpand As Integer ' 1 = X side, 2 = Y side Dim PersonToExpand As Long Dim PriorTupleCt As Integer Dim FoundAConnection As Boolean Dim MatchesFound As Integer Dim FPRin As Long Dim PFMRin As Long Dim FPSpouse As Boolean Dim PFSpouse As Boolean Dim ExpandedTupleCt As Integer ' MaxTuples captures the highest number of tuples in any ' expansion step for both X and Y, for display. Dim MaxTuples(1 To 2) As Integer Dim MatchTupleLoopCt As Integer Dim MatchCheckMRin As Long Dim MatchedRin As Long Dim MatchedMRin1(1 To LevelLimit) As Long Dim MatchedRole1(1 To LevelLimit) As Boolean Dim MatchedXRin(1 To LevelLimit) As Long Dim MatchedMRin2(1 To LevelLimit) As Long Dim MatchedRole2(1 To LevelLimit) As Boolean Dim MatchedRole1Text(1 To LevelLimit) As String Dim MatchedRole2Text(1 To LevelLimit) As String Dim BacktrackLevel As Integer Dim BacktrackSide As Integer Dim BacktrackTuple As Integer Dim BacktrackTupleNum As Integer Dim BacktrackLevelLoopCt As Integer Dim BacktrackTupleLoopCt As Integer Dim LoopCt As Long Dim LoopCt2 As Long Dim XYCt As Integer Dim RightSide As String Dim LeftSide As String 'The following are for writing the results out. Dim j As Integer ' The output line counter Sub NBRSearch() '************************* '* START OF MAIN PROGRAM * '************************* '**************************** '* Click in this area, and * '* select RUN from the menu.* '**************************** StartTime = Time Call InitVars ' Initialize the variables, so that restarts run correctly Call ReadGEDCOM ' Read the GEDCOM File and assign all the variables. PrepEndTime = Time showit = "Start-" & StartTime & " PrepEnd-" & PrepEndTime & " NRINS =" & NRINS & " MAXRIN =" & MAXRIN & " NMRINS =" & NMRINS & " MAXMRIN =" & MAXMRIN 'MsgBox showit For ExpansionStep = 1 To LevelLimit SideToExpand = X Call ExpandOneLevel If UnableToExpandLevel Then GoTo SearchDone End If ' If UnableToExpandLevel Call CheckForMatch If FoundAConnection Then GoTo SearchDone End If ' If FoundAConnection SideToExpand = Y Call ExpandOneLevel If UnableToExpandLevel Then GoTo SearchDone End If ' If UnableToExpandLevel Call CheckForMatch If FoundAConnection Then GoTo SearchDone End If ' If FoundAConnection Next ' For ExpansionStep = 1 To ExpansionLimit SearchDone: SearchEndTime = Time showit = "Start-" & StartTime & " PrepEnd-" & PrepEndTime & " SearchEnd-" & SearchEndTime & " MaxTuples for X=" & MaxTuples(1) & " - for y=" & MaxTuples(2) & " Expanded to " & ExpansionStep & " Levels" & " and MatchesFound = " & MatchesFound MsgBox showit If FoundAConnection = False Then showit = "No Connection Found Between RIN " & XPerson & " and RIN " & YPerson MsgBox showit End If '************************* '* END OF MAIN PROGRAM * '************************* End Sub Function InitVars() Set wout = Sheets("Results Report") NRINS = 0 MAXRIN = 0 NMRINS = 0 MAXMRIN = 0 MaxTuples(1) = 0 MaxTuples(2) = 0 MatchesFound = 0 For LoopCt = 1 To RINLimit For XYCt = 1 To 2 RinFlag(XYCt, LoopCt) = False Next ' For XYCt = 1 To 2 RinName(LoopCt) = "" For LoopCt2 = 1 To PFLimit PersFam(LoopCt, LoopCt2) = 0 Next ' For LoopCt2 = 1 To PFLimit If LoopCt < MRINLimit + 1 Then MRinExpanded(1, LoopCt) = False MRinExpanded(2, LoopCt) = False For LoopCt2 = 1 To FPLimit FamPers(LoopCt, LoopCt2) = 0 Next ' For LoopCt2 = 1 To FPLimit End If ' If LoopCt < MRINLimit + 1 Then Next ' For LoopCt = 1 To RINLimit For LoopCt = 1 To LevelLimit For LoopCt2 = 1 To TupleLimit For XYCt = 1 To 2 Mrin1(XYCt, LoopCt, LoopCt2) = 0 Role1(XYCt, LoopCt, LoopCt2) = False XRin(XYCt, LoopCt, LoopCt2) = 0 Mrin2(XYCt, LoopCt, LoopCt2) = 0 Role2(XYCt, LoopCt, LoopCt2) = False Next ' Next ' For LoopCt2 = 1 To TupleLimit Next ' For LoopCt = 1 To LevelLimit UnableToExpandLevel = False FoundAConnection = False End Function Function ReadGEDCOM() '**************************************** '* Read through the GEDCOM file and '* 1. Define RIN-Name Index and X and Y RIN Flag Arrays '* 2. Define Family-Person File and Family Counter Array '* Only the INDI records of the GEDCOM file are used. '**************************************** Const ForReading = 1, ForWriting = 2, ForAppending = 3 Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0 Dim fso, ts, s Set fso = CreateObject("Scripting.FileSystemObject") Set ts = fso.OpenTextFile(GEDCOMFile, ForReading, TristateUseDefault) Dim RINSDone As Boolean RINSDone = False Dim EndofINDI As Boolean EndofINDI = False Dim PersCount As Integer ' Will run from 1 to FPLimit Dim FamCount As Integer ' Will run from 1 to PFLimit 'Dim loopct As Integer 'For loopct = 1 To 500 Do While ts.AtEndOfLine <> True s = ts.ReadLine FoundZeroINDI: If RINSDone = False Then ' Remember that there are "0" records before the first "0 INDI". If Left(s, 1) = 0 Then If Right(s, 4) = "INDI" Then NRINS = NRINS + 1 ' Count the number of RINs in the file RightSide = Right(s, Len(s) - 4) For ctspaces = 1 To 10 If Mid(RightSide, ctspaces, 1) = "@" Then GoTo FoundRinAt End If Next FoundRinAt: Rin = (Left(RightSide, (ctspaces - 1))) ' now read the next line which is the name line s = ts.ReadLine RinName(Rin) = Right(s, Len(s) - 7) ' Now, find any FAMS or FAMC records for this person and load to arrays. EndofINDI = False Do Until EndofINDI = True s = ts.ReadLine If Left(s, 1) = 0 Then EndofINDI = True 'GoTo EndofINDI End If ' If Right(s, 3) = "FAM" If Left(s, 1) <> 1 Then GoTo LoopToFindFAM End If ' If Left(s, 1) <> 1 ' You have found a "1" record. So check to see if it is a FAM. If Mid(s, 3, 4) = "FAMS" Then ' Write as as plus ' Parse the MRIN. RightSide = Right(s, Len(s) - 9) For ctspaces = 1 To 10 If Mid(RightSide, ctspaces, 1) = "@" Then GoTo FoundSMRinAt End If Next FoundSMRinAt: MRin = (Left(RightSide, (ctspaces - 1))) ' Store in the Family-Person Array For PersCount = 1 To FPLimit If FamPers(MRin, PersCount) = 0 Then FamPers(MRin, PersCount) = Rin GoTo LoadFAMStoPF End If ' Since this Rin slot is already filled, check the next one. Next ' For PersCount = 1 To 30 LoadFAMStoPF: ' Store in the Person-Family Array For FamCount = 1 To PFLimit If PersFam(Rin, FamCount) = 0 Then PersFam(Rin, FamCount) = MRin GoTo LoopToFindFAM ' done processing this FAMS record End If ' Since this Rin slot is already filled, check the next one. Next ' For FamCount = 1 To 30 End If ' If Right(s, 4) = "FAMS" If Mid(s, 3, 4) = "FAMC" Then ' Write as as minus ' Parse the MRIN. RightSide = Right(s, Len(s) - 9) For ctspaces = 1 To 10 If Mid(RightSide, ctspaces, 1) = "@" Then GoTo FoundCMRinAt End If Next FoundCMRinAt: MRin = (Left(RightSide, (ctspaces - 1))) ' Store in the Family-Person Array For PersCount = 1 To FPLimit If FamPers(MRin, PersCount) = 0 Then FamPers(MRin, PersCount) = -Rin GoTo LoadFAMCtoPF End If ' Since this Rin slot is already filled, check the next one. Next ' For PersCount = 1 To 30 LoadFAMCtoPF: ' Store in the Person-Family Array For FamCount = 1 To PFLimit If PersFam(Rin, FamCount) = 0 Then PersFam(Rin, FamCount) = -MRin GoTo LoopToFindFAM ' done processing this FAMS record End If ' Since this Rin slot is already filled, check the next one. Next ' For FamCount = 1 To 30 End If ' If Right(s, 4) = "FAMC" LoopToFindFAM: Loop ' Do Until EndofINDI = True EndofINDI: ' You have finished the current individual's records. If Right(s, 3) = "FAM" Then ' The first "0 FAM" indicates RINS are done. RINSDone = True GoTo RINSDone End If ' If Right(s, 3) = "FAM" GoTo FoundZeroINDI: ' go back and process the new individual you have found. Else ' If Right(s, 4) = "INDI" Then If Right(s, 3) = "FAM" Then ' The first "0 FAM" indicates RINS are done. RINSDone = True GoTo RINSDone End If ' If Right(s, 3) = "FAM" Then End If ' If Right(s, 4) = "INDI" Then End If ' If Left(s, 1) = 0 Then Else ' If RINSDone = False Then End If ' If RINSDone = False Then RINSDone: 'Next ' For loopct = 1 To 100 Loop 'Do While ts.AtEndOfLine <> True ts.Close MAXRIN = Rin ' Capture the highest RIN, which will be the last one ' Figure out MAXMRIN and NMRINS For LoopCt = 1 To MRINLimit If FamPers(LoopCt, 1) <> 0 Then NMRINS = NMRINS + 1 MAXMRIN = LoopCt End If ' If FamPers(LoopCt, 1) <> 0 Next ' For LoopCt = 1 To MRINLimit End Function ' ReadGEDCOM() Function ExpandOneLevel() ' Uses SideToExpand (X = 1 or Y = 2) as an index value Dim StepOneXYLoopCt As Integer Dim StepOneRinLoopCt As Long Dim StepOneMRinLoopCt As Long Dim ExpandPFLoopCt As Long Dim ExpandFPLoopCt As Long Dim FPRin As Long Dim PFMRin As Long ExpandedTupleCt = 0 If ExpansionStep = 1 Then ' Set the flag to say this person is expanded on this side If SideToExpand = X Then PersonToExpand = XPerson Else PersonToExpand = YPerson End If ' If SideToExpand = X RinFlag(SideToExpand, PersonToExpand) = True ' Expand all the MRINs in which this person is a spouse or child. For StepOneMRinLoopCt = 1 To PFLimit If PersFam(PersonToExpand, StepOneMRinLoopCt) = 0 Then GoTo EndExpandOneLevel End If ' If PersFam(SideToExpand, StepOneMRinLoopCt) = 0 ExpandedTupleCt = ExpandedTupleCt + 1 Mrin1(SideToExpand, ExpansionStep, StepOneMRinLoopCt) = 0 Role1(SideToExpand, ExpansionStep, StepOneMRinLoopCt) = False XRin(SideToExpand, ExpansionStep, StepOneMRinLoopCt) = PersonToExpand MRin = PersFam(PersonToExpand, StepOneMRinLoopCt) If MRin > 0 Then ' Person is a spouse in the MRIN Mrin2(SideToExpand, ExpansionStep, StepOneMRinLoopCt) = MRin Role2(SideToExpand, ExpansionStep, StepOneMRinLoopCt) = True Else ' Person is a child in the MRIN Mrin2(SideToExpand, ExpansionStep, StepOneMRinLoopCt) = -MRin Role2(SideToExpand, ExpansionStep, StepOneMRinLoopCt) = False MRin = -MRin End If ' If PersFam(SideToExpand, StepOneMRinLoopCt) > 0 ' Set the MRINExpanded flag to say that this side has expanded this MRin. MRinExpanded(SideToExpand, MRin) = True Next ' For StepOneMRinLoopCt = 1 To PFLimit GoTo EndExpandOneLevel End If ' If ExpansionStep = 1 ' So now we know we are processing a second or higher level expansion step. '****************************************************************************** '* For each tuple in the prior level, find its generated MRIN and * '* expand that MRIN, if possible. * '* The MRIN is expanded by finding all unexpanded members of the family * '* and then finding all other families in which they are members. * '* So there are 3 levels of search: prior tuple, FamPers, PersFam. * '****************************************************************************** 'Level 1 of Search - Prior Tuple ExpandedTupleCt = 0 For PriorTupleCt = 1 To TupleLimit Rin = XRin(SideToExpand, ExpansionStep - 1, PriorTupleCt) If Rin = 0 Then GoTo EndExpandOneLevel ' if no more tuples, then end End If ' If Rin = 0 ' Set the prior generated family to consider for expansion. MRin = Mrin2(SideToExpand, ExpansionStep - 1, PriorTupleCt) 'Level 2 of Search - FamPers, using MRin and ExpandFPLoopCt to find FPRin ' Search the generated Family's Persons to see if any should be expanded. For ExpandFPLoopCt = 1 To FPLimit FPRin = FamPers(MRin, ExpandFPLoopCt) If FPRin = 0 Then ' There are no more people in the family being expanded. GoTo LoopToNextTuple End If ' If FPRin = 0 ' Check to see if this Rin has already been expanded on this side. If FPRin < 0 Then FPRin = -FPRin FPSpouse = False Else FPSpouse = True End If If RinFlag(SideToExpand, FPRin) = True Then GoTo LoopToNextFamPers End If ' If RinFlag(SideToExpand, FPRin) = True 'Level 3 of Search - PersFam, Using FPRin and ExpandPFLoopCt to find PFMRin ' Now see if any of this Person's Families are still expandable. For ExpandPFLoopCt = 1 To PFLimit PFMRin = PersFam(FPRin, ExpandPFLoopCt) ' If the new MRin is zero, then you are done with the PersFam loop ' and can cycle through for the next FamPers record If PFMRin = 0 Then GoTo LoopToNextFamPers End If ' If PFMrin = 0 ' Set the MRin to its absolute value and capture role from sign of MRin. If PFMRin > 0 Then PFSpouse = True Else PFSpouse = False PFMRin = -PFMRin End If ' If PFMrin > 0 ' If the new MRin is the same as the prior generated MRin, do not ' try to expand this MRin. Instead, go to the next PersFam MRIN. If PFMRin = MRin Then GoTo LoopToNextPersFam End If ' If PFMRin = MRin ' If the new MRin has already been generated by both sides (i.e matched), ' do not expand this MRin. Instead, go to the next PersFam MRIN. If MRinExpanded(1, PFMRin) And MRinExpanded(2, PFMRin) Then GoTo LoopToNextPersFam End If ' MRinExpanded(1, PFMRin) And MRinExpanded(2, PFMRin) ' So now we know that we have an expandable MRin for this person. ' First set the flags and counters. RinFlag(SideToExpand, FPRin) = True ' Indicate the Person is now expanded MRinExpanded(SideToExpand, PFMRin) = True ' Set flag: expanded by this side ExpandedTupleCt = ExpandedTupleCt + 1 ' Increment Count of new tuples ' Now write a new tuple in the present level of the expansion set. Mrin1(SideToExpand, ExpansionStep, ExpandedTupleCt) = MRin Role1(SideToExpand, ExpansionStep, ExpandedTupleCt) = FPSpouse XRin(SideToExpand, ExpansionStep, ExpandedTupleCt) = FPRin Mrin2(SideToExpand, ExpansionStep, ExpandedTupleCt) = PFMRin Role2(SideToExpand, ExpansionStep, ExpandedTupleCt) = PFSpouse LoopToNextPersFam: Next ' For ExpandPFLoopCt = 1 To PFLimit 'END OF Level 3 of Search - PersFam, Using FPRin and ExpandPFLoopCt to find PFMRin LoopToNextFamPers: Next ' For StepOneFPLoopCt = 1 To FPLimit 'END OF Level 2 of Search - FamPers, using MRin and ExpandFPLoopCt to find FPRin LoopToNextTuple: Next ' For PriorTupleCt = 1 To TupleLimit 'END OF Level 1 of Search - Prior Tuple EndExpandOneLevel: If ExpandedTupleCt = 0 Then UnableToExpandLevel = True End If ' If ExpandedTupleCt = 0 'showit = "ExpansionStep " & ExpansionStep & " for SideToExpand= " & SideToExpand & " ExpandedTupleCt = " & ExpandedTupleCt 'MsgBox showit 'For xxx = 1 To 3 ' ExpandedTupleCt ' Detail of each tuple ' showit = Mrin1(SideToExpand, ExpansionStep, xxx) & "-" & Role1(SideToExpand, ExpansionStep, xxx) & "--" & XRin(SideToExpand, ExpansionStep, xxx) & "--" & Mrin2(SideToExpand, ExpansionStep, xxx) & "--" & Role2(SideToExpand, ExpansionStep, xxx) ' MsgBox showit 'Next If ExpandedTupleCt > MaxTuples(SideToExpand) Then MaxTuples(SideToExpand) = ExpandedTupleCt End If End Function ' ExpandOneLevel Function CheckForMatch() '*************************************************** '* Step through this sides new generated families, * '* and see if any of them have been matched. * '*************************************************** For MatchTupleLoopCt = 1 To ExpandedTupleCt MatchCheckMRin = Mrin2(SideToExpand, ExpansionStep, MatchTupleLoopCt) 'If no match, then check next generated family in this expansion set. If MRinExpanded(1, MatchCheckMRin) = False Or MRinExpanded(2, MatchCheckMRin) = False Then GoTo LoopToNextTupleGeneratedFam End If ' If MRinExpanded(1, MatchCheckMRin) = False Or MRinExpanded(2, MatchCheckMRin) = False '*************************************************************************** '* BINGO !!! * '* At this point, we have an MRIN that matches the other side. * '* So backtrack this side for display, and then find all instances of this * '* MRIN on the other side and backtrack each one of those. * '*************************************************************************** FoundAConnection = True showit = "Matched on MRIN " & MatchCheckMRin & " in Expansion Step " & ExpansionStep & " on side " & SideToExpand 'MsgBox showit ' Backtrack this side at the current level MatchesFound = MatchesFound + 1 Call Backtrack LoopToNextTupleGeneratedFam: Next ' For MatchTupleLoopCt = 1 To ExpandedTupleCt StopLookingForMatch: End Function Function Backtrack() ' You arrive here with the variable MatchCheckMRin set to the matching MRin2 ' You also have the values of SideToExpand, ExpansionStep, MatchTupleLoopCt ' So you know which tuple the match is in. ' First check to see if this is the first match or not -- and thus ' whether to start or to continue the output spreadsheet. If MatchesFound = 1 Then Set wout = Sheets("Results Report") wout.Activate wout.Cells.ClearContents j = 1 End If ' If MatchesFound = 1 Set wout = Sheets("Results Report") wout.Activate wout.Cells(j, 1) = "" j = j + 1 wout.Cells(j, 1) = "Match Found on MRin " & MatchCheckMRin & " -- X (" & RinName(XPerson) & ") and Y (" & RinName(YPerson) & ") are related." j = j + 1 If SideToExpand = 1 Then wout.Cells(j, 1) = "Expanding Side X backwards to X" j = j + 1 BacktrackLevel = ExpansionStep BacktrackSide = 1 ' Same as SideToExpand BacktrackTuple = MatchTupleLoopCt Call BacktrackOneSide wout.Cells(j, 1) = "Expanding Side Y backwards to Y" j = j + 1 ' Must first locate the matched family on the X side highest level as an MRin2. BacktrackLevel = ExpansionStep - 1 ' X has expanded one more level than Y BacktrackSide = 2 ' The Other Side For BacktrackTuple = 1 To TupleLimit If Mrin2(BacktrackSide, BacktrackLevel, BacktrackTuple) = MatchCheckMRin Then GoTo FoundMRinOnYSide End If ' If Mrin2(BacktrackSide, BacktrackLevel, BacktrackTuple) = MatchCheckMRin Next ' For BacktrackTupleLoopCt = 1 To TupleLimit FoundMRinOnYSide: Call BacktrackOneSide Else wout.Cells(j, 1) = "Expanding Side Y backwards to Y" j = j + 1 BacktrackLevel = ExpansionStep BacktrackSide = 2 ' Same as SideToExpand BacktrackTuple = MatchTupleLoopCt Call BacktrackOneSide wout.Cells(j, 1) = "Expanding Side X backwards to X" j = j + 1 ' Must first locate the matched family on the X side highest level as an MRin2. BacktrackLevel = ExpansionStep ' Y has expanded the same levels as X BacktrackSide = 1 ' The Other Side For BacktrackTuple = 1 To TupleLimit If Mrin2(BacktrackSide, BacktrackLevel, BacktrackTuple) = MatchCheckMRin Then GoTo FoundMRinOnXSide End If ' If Mrin2(BacktrackSide, BacktrackLevel, BacktrackTuple) = MatchCheckMRin Next ' For BacktrackTupleLoopCt = 1 To TupleLimit FoundMRinOnXSide: Call BacktrackOneSide End If ' If SideToExpand = 1 ' First Expand the side on which the match was discovered. End Function Function BacktrackOneSide() ' The first report line will be uniquely formatted. The rest can loop. ' Each subsequent level will be indented with a dash "-", one dash per level. Dim woutline As String MatchedMRin1(BacktrackLevel) = Mrin1(BacktrackSide, BacktrackLevel, BacktrackTuple) MatchedRole1(BacktrackLevel) = Role1(BacktrackSide, BacktrackLevel, BacktrackTuple) MatchedXRin(BacktrackLevel) = XRin(BacktrackSide, BacktrackLevel, BacktrackTuple) MatchedMRin2(BacktrackLevel) = Mrin2(BacktrackSide, BacktrackLevel, BacktrackTuple) MatchedRole2(BacktrackLevel) = Role2(BacktrackSide, BacktrackLevel, BacktrackTuple) 'showit = "MATCH Level = " & BacktrackLevel & " Tuple " & MatchTupleLoopCt & " = " & MatchedMRin1(BacktrackLevel) & "," & MatchedRole1(BacktrackLevel) & "," & MatchedXRin(BacktrackLevel) & "," & MatchedMRin2(BacktrackLevel) & "," & MatchedRole2(BacktrackLevel) 'MsgBox showit If MatchedRole1(BacktrackLevel) Then MatchedRole1Text(BacktrackLevel) = "spouse" Else MatchedRole1Text(BacktrackLevel) = "child" End If ' If MatchedRole2 If MatchedRole2(BacktrackLevel) Then MatchedRole2Text(BacktrackLevel) = "spouse" Else MatchedRole2Text(BacktrackLevel) = "child" End If ' If MatchedRole2 Set wout = Sheets("Results Report") wout.Activate wout.Cells(j, 1) = RinName(MatchedXRin(BacktrackLevel)) & " is a " & MatchedRole2Text(BacktrackLevel) & " in the matched family (" & MatchedMRin2(BacktrackLevel) & ")." j = j + 1 If BacktrackLevel = 1 Then GoTo DoneBacktrackThisSide End If ' If BacktrackLevel = 1 Indenttext = "" For BacktrackLevelLoopCt = (BacktrackLevel - 1) To 1 Step -1 ' Find the MRin1 of the higher level as MRin2 in the lower level-may be more than one Indenttext = Indenttext & "-" For BacktrackTupleLoopCt = 1 To TupleLimit 'showit = "Level = " & BacktrackLevelLoopCt & " Tuple " & BacktrackTupleLoopCt & " = " & MatchedMRin1(BacktrackLevelLoopCt) & "," & MatchedRole1(BacktrackLevelLoopCt) & "," & MatchedXRin(BacktrackLevelLoopCt) & "," & MatchedMRin2(BacktrackLevelLoopCt) & "," & MatchedRole2(BacktrackLevelLoopCt) 'MsgBox showit If XRin(BacktrackSide, BacktrackLevelLoopCt, BacktrackTupleLoopCt) = 0 Then GoTo DoneWithTupleSearch End If ' If XRin(BacktrackSide, BacktrackLevelLoopCt, BacktrackTupleLoopCt) = 0 'showit = "made it here - BacktrackLevelLoopCt=" & BacktrackLevelLoopCt & " with MatchedMRin2(BacktrackLevelLoopCt) = " & MatchedMRin2(BacktrackLevelLoopCt) & " and MatchedMRin1(BacktrackLevelLoopCt + 1) = " & MatchedMRin1(BacktrackLevelLoopCt + 1) 'MsgBox showit If Mrin2(BacktrackSide, BacktrackLevelLoopCt, BacktrackTupleLoopCt) <> MatchedMRin1(BacktrackLevelLoopCt + 1) Then GoTo CycleToNextTuple End If ' If Mrin2(BacktrackSide, BacktrackLevelLoopCt, BacktrackTupleLoopCt) <> MatchedMRin1(BacktrackLevelLoopCt + 1) ' So now we have found the higher level MRin1 as an MRin2 in the lower level ' And we can output a line. MatchedMRin1(BacktrackLevelLoopCt) = Mrin1(BacktrackSide, BacktrackLevelLoopCt, BacktrackTupleLoopCt) MatchedRole1(BacktrackLevelLoopCt) = Role1(BacktrackSide, BacktrackLevelLoopCt, BacktrackTupleLoopCt) MatchedXRin(BacktrackLevelLoopCt) = XRin(BacktrackSide, BacktrackLevelLoopCt, BacktrackTupleLoopCt) MatchedMRin2(BacktrackLevelLoopCt) = Mrin2(BacktrackSide, BacktrackLevelLoopCt, BacktrackTupleLoopCt) MatchedRole2(BacktrackLevelLoopCt) = Role2(BacktrackSide, BacktrackLevelLoopCt, BacktrackTupleLoopCt) If MatchedRole1(BacktrackLevelLoopCt) = True Then MatchedRole1Text(BacktrackLevelLoopCt) = "spouse" Else MatchedRole1Text(BacktrackLevelLoopCt) = "child" End If ' If MatchedRole2 If MatchedRole2(BacktrackLevelLoopCt) = True Then MatchedRole2Text(BacktrackLevelLoopCt) = "spouse" Else MatchedRole2Text(BacktrackLevelLoopCt) = "child" End If ' If MatchedRole2 woutline = Indenttext woutline = woutline & RinName(MatchedXRin(BacktrackLevelLoopCt)) & " is a " & MatchedRole2Text(BacktrackLevelLoopCt) woutline = woutline & " in the family (" & MatchedMRin2(BacktrackLevelLoopCt) woutline = woutline & ") in which " & RinName(MatchedXRin(BacktrackLevelLoopCt + 1)) & " is a " & MatchedRole1Text(BacktrackLevelLoopCt + 1) wout.Cells(j, 1) = woutline j = j + 1 CycleToNextTuple: Next ' For BacktrackTupleLoopCt = 1 To TupleLimit DoneWithTupleSearch: CycleToNextLevel: 'showit = "made it here - BacktrackLevelLoopCt = " & BacktrackLevelLoopCt 'MsgBox showit Next ' For BacktrackLevelLoopCt = BacktrackLevel To 1 Step -1 DoneBacktrackThisSide: End Function