My article in the July/August/September 2003 issue of Genealogical Computing gives the theory and the steps to build a non-blood relationship search of a family history database. This web page contains the practical implementation of such a search, written in Microsoft Excel Visual Basic. You are free to copy the program code for your own use. There are no guarantees nor warrantees on its use, and -- due to my health limitations -- it will not be maintained or upgraded, and I will NOT answer e-mail questions about it.

This program is a proof-of-concept. I wanted to prove that a non-blood relationship search is possible, since it seems that many people have come to believe it is too horrendously complicated to ever work efficiently. So this is a proof that it can be done and can run quickly. So my effort went into the search, and there is much to be desired about how the results are presented or how you tell it the two people on whom you want to search for a relationship. As you use the program, you will think of lots of ways to build upon and improve the program. I can already see MANY ways in which this program can be improved, but I am leaving that up to the commercial vendors of genealogical database software. They should incorporate non-blood relationship searches as a standard feature, if they want to be considered as quality products from this time forward.

Please read the article in Genealogical Computing (July/August/September 2003 issue) if you want any more information.

Setting Things Up
1. The program works on a GEDCOM export of your family database. So first, export your database to a GEDCOM file. You'll also need to note down what the RINs are for the two people who you want to search for a relationship. You will make things a lot easier for yourself (as you will see below) if you copy the GEDCOM file into your hard drive's root directory and rename it to "aaa.ged".
2. Open a new Microsoft Excel file and worksheet. Save the file as "NBR Search.xls", but do not close it.
3. Create a worksheet in the Excel file, and name it "Results Report".
4. In the Excel spreadsheet, click on "Tools" in the top menu. Then click on "Macro" in the pulldown menu of tools. Then click on "Visual Basic Editor" in the Macro pulldown menu. This will place you into the Visual Basic Editor -- which is uncharted wilderness country for most people.
5. On the left side of the Visual Basic Editor, you should see "VBAProject(NBRSearch.xls)". If it has a plus sign (+) in the box to its left, click on the plus sign to expand the project. Once you see something like "Sheet2(Results Report)" (the sheet number could be different; it is the name we are looking for), then double-click on it. The right side should now be a big blank window. Copy the program code from this web page (below), and paste it into that blank window. Then do a FILE/SAVE from the menu at the top of the Visual Basic Editor.

   Entering Your Instructions

6. To tell the program what search you want to make, you must make three changes to the program. These are all right at the top, and there is a box there to tell you exactly what to change. You put the RINs of the two people you are searching in as the values on the right side of the equal sign (=) for XPerson and YPerson. It does not matter which person is X or Y. Then inside the quotes on the GEDCOMFile line, you must enter the complete path name and file name of the GEDCOM file you want to search. This is why I said it would be easiest if you put the GEDCOM file in your hard drive's root directory: you then do not have to worry about a long path name and can just enter something like "c:/aaa.ged".

   Running the Program

7. Now you are ready to run the search. VERY IMPORTANT AND EASILY OVERLOOKED STEP: You first have to scroll down in the program code until you can click somewhere in the "Sub NBRSearch()" section. As long as you click on or between the lines "Sub NBRSearch()" and "End Sub", you are fine. In the code below, these lines are highlighted in bold red, but they will not be highlighted once you paste them into Excel. So note them here.
8. Now you can start the program running in any one of at least three ways.
   1. Press the F5 key -- that is the easiest way.
   2. Click the right-pointing arrowhead icon in the menu bar at the top of the screen -- that is the next easiest way.
   3. Click "Run" on the top menu, and then click "Run Sub/User Form" -- that is the hardest way.
9. The program will run and then display a window with start and end times and with counts of the most tuples in any level and of how many levels were used and how many matches were found. When you click OK on this window, one of two things may happen. If there were no relationships found, another window will pop up to say so. If there were relationships found, you will be placed back in the Visual Basic Editor window; so switch over to the Excel window, so that you can see the results that were written in the "Results Report" worksheet.

Code starts on next line. Copy from there until just before the indicator of the end of the code.

'************************************************************
'* 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

Code ends on previous line