Creation of arrows for 2 family trees.

H

harzer

Board Regular
Joined
Dec 15, 2021
Messages
122
Office Version
  1. 2016
Platform
  1. Windows
Hello everyone,
I would like to post my request in the hope that you can help me solve my problem.
I often retrieve two family trees (of two different birds) via genealogy software, then I transfer this data to an Excel sheet and then I try to put the arrows to link each bird to its parents despite the constraints that this causes. However, this work requires a lot of time and a lot of patience and it even happens that I get tired of my vision. Eye pain.
Could you please help me automate this work via a loop for the two birds at the start which are respectively in cells "A64" and "A149", these two cells are colored yellow. I would like to point out that the two starting birds are not always in the same cells, hence the need to determine their locations before launching the Macro.
In the example here, the tree was created for seven generations ==> which means that there is data up to column "G" (7th column), it may happen that the tree can hold more generations, can you please consider this detail, if it's not possible I can settle for 7 generations.
I manually put arrows up to column "D" but we can't see them.
Thank you in advance for your answers.

Here is a presentation of my request:

Fleches_Arbre.xlsm
ABCDEFG
1CONSANGUINITÉNbre de générations7Max 20 Générations
2
3AE-077/2012 M
4Gu-015/2014 M
5Gu-039/2011 F
6Gu-042/2015 M
7Gu-139/2011 M
8Gu-045/2014 F
9AE-044/2011 F
10AE-031/2016 M
11Ni-056/2012 M
12Ni-040/2013 M
13Ni-032/2012 F
14AE-134/2015 F
15AE-027/2011 M
16AE-173/2013 F
17Ma-053/2011 F
18AE-032/2017 M
19Ni-056/2012 M
20Ni-040/2013 M
21Ni-032/2012 F
22AE-115/2015 M
23Gu-139/2011 M
24Gu-017/2014 F
25Gu-036/2013 F
26AE-009/2016 F
27AE-077/2012 M
28Gu-003/2014 M
29AE-044/2011 F
30Gu-006/2015 F
31AE-110/2011 M
32Gu-135/2013 F
33Gu-066/2010 F
34AE-049/2021 M
35Gu-039/2014 M
36Gu-014/2017 M
37Gu-107/2014 F
38Gu-022/2018 M
39Gu-101/2014 M
40Gu-013/2016 F
41Gu-045/2014 F
42478-025/2019 M
43Gu-004/2017 M
44Gu-062/2018 F
45AE-115/2015 M
46AE-005/2017 F
47Gu-069/2016 F
48AE+-016/2020 F
49Gu-101/2014 M
50Gu-001/2016 M
51Gu-037/2014 F
52AE-032/2018 M
53AE-074/2015 M
54AE-091/2016 F
55AE-052/2015 F
56AE-069/2019 F
57AE-031/2016 M
58AE-032/2017 M
59AE-009/2016 F
60HTY32-028/2018 F
61Gu-101/2014 M
62Gu-019/2017 F
63Gu-025/2015 F
64AE-022/2022 M
65Ni-056/2012 M
66Ni-137/2014 M
67Ni-120/2013 F
68Ni-083/2015 M
69Ni-121/2013 M
70Ni-106/2014 F
71Ni-032/2013 F
72Ni-043/2017 M
73Ni-137/2014 M
74Ni-084/2015 M
75Ni-106/2014 F
76Ni-027/2016 F
77Ni-055/2014 M
78Ni-039/2015 F
79Ni-051/2014 F
80Ni-046/2019 M
81Ni-056/2012 M
82Ni-029/2013 M
83Ni-070/2013 F
84Ni-055/2014 M
85Ni-009/2011 M
86Ni-071/2013 F
87Ni-064/2011 F
88Ni-065/2017 F
89AE-014/2011 M
90HWA76-022/2013 M
91AE-011/2012 F
92Ni-051/2014 F
93Ni-078/2012 M
94Ni-023/2013 F
95HWA76-069/2011 F
96AE-003/2021 F
97Ma-063/2011 M
98Ma-101/2012 M
99Ma-069/2010 F
100Gu-101/2014 M
101HTY03*-156/2011 M
102AE-096/2012 F
103HWA72-114/2011 F
104Gu-003/2018 M
105AE-078/2012 M
106AE-077/2013 M
107Ma-083/2012 F
108Gu-037/2014 F
109Gu-139/2011 M
110Gu-103/2013 F
111AE-015/2011 F
112AE-010/2019 F
113Ni-056/2012 M
114Ni-040/2013 M
115Ni-032/2012 F
116AE-052/2014 M
117Ma-022/2009 M
118Ni-075/2012 F
119HWA76-016/2010 F
120AE-003/2018 F
121AE-077/2012 M
122Gu-003/2014 M
123AE-044/2011 F
124Gu-008/2015 F
125Gu-139/2011 M
126Gu-019/2014 F
127Gu-036/2013 F
128
129
130Ni-046/2018 M
131Ni+-021/2019 M
132Ni-048/2018 F
133Ni-002/2020 M
134Ni-035/2014 M
135Ni-054/2018 F
136Ni-076/2017 F
137Ni-008/2021 M
138Ni-035/2014 M
139Ni-020/2020 F
140AE-031/2016 M
141AE-034/2017 M
142AE-009/2016 F
143AE-058/2018 M
144AE-052/2014 M
145AE-018/2017 F
146AE-067/2016 F
147Ni-019/2019 F
148Ni-047/2018 F
149AE-015/2023 F
150Ni-137/2014 M
151Ni-083/2015 M
152Ni-106/2014 F
153Ni-043/2017 M
154Ni-084/2015 M
155Ni-027/2016 F
156Ni-039/2015 F
157Ni-045/2019 M
158Ni-029/2013 M
159Ni-055/2014 M
160Ni-071/2013 F
161Ni-065/2017 F
162HWA76-022/2013 M
163Ni-051/2014 F
164Ni-023/2013 F
165Ni-005/2021 M
166Ni-046/2018 M
167Ni+-021/2019 M
168Ni-048/2018 F
169Ni-024/2020 F
170Ni-083/2015 M
171Ni-043/2017 M
172Ni-027/2016 F
173Ni-022/2019 F
174Ni-055/2014 M
175Ni-065/2017 F
176Ni-051/2014 F
177AE-037/2022 F
178Gu-014/2017 M
179Gu-022/2018 M
180Gu-013/2016 F
181478-025/2019 M
182Gu-004/2017 M
183Gu-062/2018 F
184AE-005/2017 F
185AE+-015/2020 M
186Gu-001/2016 M
187AE-032/2018 M
188AE-091/2016 F
189AE-069/2019 F
190AE-032/2017 M
191HTY32-028/2018 F
192Gu-019/2017 F
193AE-068/2021 F
194AE-048/2015 M
195AE-029/2017 M
196AE-091/2016 F
197AE-009/2018 M
198Gu-001/2016 M
199Gu-011/2017 F
200Gu-045/2015 F
201AE-014/2020 F
202Gu-101/2014 M
203Gu-003/2018 M
204Gu-037/2014 F
205AE-012/2019 F
206AE-052/2014 M
207AE-003/2018 F
208Gu-008/2015 F
Feuil1


Here is a picture :
 
Last edited:

Excel Facts

Repeat Last Command
Pressing F4 adds dollar signs when editing a formula. When not editing, F4 repeats last command.
Sort by date Sort by votes
Here is a picture to show the arrows in the family tree
1.jpg
 
Upvote 0
Hello everyone,
I have some code that could add the arrows in a family tree but I don't know how to use it, I'm making it available to you, in case anyone knows how to use it.

VBA Code: 
Sub The_arrows(c1, c2)
     '********************************
     '''create the arrows in the pedigree diagram
     '********************************
     t1 = c1.Top + c1.Height / 2
     t2 = c2.Top + c2.Height / 2
     L1 = c1.Left + c1.Width - 10
     l2 = c2.Left + 10
     Set p = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, L1, t1, l2, t2)
     p.Line.EndArrowheadStyle = msoArrowheadTriangle
End Sub
 
Upvote 0
Hi @harzer

Try the following code, it works for 2 families or more.
It also works for 7 generations or 20 generations or more.

The conditions are, as shown in your example.
- Initial families must start in column A.
- The first row with data is row 3.
- The arrow is the one that Excel puts by default, blue, thin and msoArrowheadTriangle arrow.
- Not all "birds" reach the last generation.

Ex:
1709688957067.png



Code:

VBA Code: 
Sub Creation_of_arrows()
  Dim lr As Long, lc As Long, i As Long, j As Long, k As Long
  Dim dic1 As Object, dic2 As Object
  Dim ini As Range, fin As Range
  Dim shp As Shape
  Dim sh As Worksheet
  
  Application.ScreenUpdating = False
  
  Set sh = ActiveSheet
  Set dic1 = CreateObject("Scripting.Dictionary")
  Set dic2 = CreateObject("Scripting.Dictionary")
  
  sh.DrawingObjects.Delete
  lr = ActiveSheet.UsedRange.Rows(sh.UsedRange.Rows.Count).Row
  lc = ActiveSheet.UsedRange.Columns(sh.UsedRange.Columns.Count).Column
  
  For j = 1 To lc
    For i = 3 To lr
      
      If Cells(i, j).Value <> "" Then
        Set ini = Cells(i, j)
        If Not dic1.exists(ini.Row) Then
          dic1(ini.Row) = Empty             'origin
          
          'to up
          For k = i - 1 To 3 Step -1
            Set fin = Cells(k, j + 1)
            If Not dic1.exists(k) Then
              If fin.Value <> "" Then
                If Not dic2.exists(fin.Row) Then
                  dic2(fin.Row) = Empty       'destination
                  Set shp = sh.Shapes.AddConnector(msoConnectorStraight, _
                    ini.Left + (3 / 4 * ini.Width), ini.Top + (ini.Height * 1 / 4), _
                    fin.Left, fin.Offset(1).Top)
                  shp.Line.EndArrowheadStyle = msoArrowheadTriangle
                  Exit For
                Else
                  Exit For
                End If
              End If
            Else
              Exit For
            End If
          Next
          
          'to down
          For k = i + 1 To lr
            Set fin = Cells(k, j + 1)
            If Not dic1.exists(k) Then
              If fin.Value <> "" Then
                If Not dic2.exists(fin.Row) Then
                  dic2(fin.Row) = Empty       'destination
                  Set shp = sh.Shapes.AddConnector(msoConnectorStraight, _
                    ini.Left + (ini.Width * 3 / 4), ini.Top + (ini.Height * 3 / 4), _
                    fin.Left, fin.Top)
                  shp.Line.EndArrowheadStyle = msoArrowheadTriangle
                  Exit For
                Else
                  Exit For
                End If
              End If
            Else
              Exit For
            End If
          Next
          
        End If
      End If
    Next
  Next
  Application.ScreenUpdating = True
End Sub

----- --
Let me know the result and I'll get back to you as soon as I can.
Sincerely
Dante Amor
----- --
 
Upvote 0
I simplified the code a bit:

Try and comment

VBA Code: 
Sub Creation_of_arrows()
  Dim lr As Long, lc As Long, i As Long, j As Long, k As Long
  Dim dic1 As Object, dic2 As Object
  Dim ini As Range, fin As Range
  Dim shp As Shape
  Dim sh As Worksheet
  
  Application.ScreenUpdating = False
  
  Set sh = ActiveSheet
  Set dic1 = CreateObject("Scripting.Dictionary")
  Set dic2 = CreateObject("Scripting.Dictionary")
  
  sh.DrawingObjects.Delete
  lr = ActiveSheet.UsedRange.Rows(sh.UsedRange.Rows.Count).Row
  lc = ActiveSheet.UsedRange.Columns(sh.UsedRange.Columns.Count).Column
  
  For j = 1 To lc
    For i = 3 To lr
      If Cells(i, j).Value <> "" Then
        Set ini = Cells(i, j)
        If Not dic1.exists(ini.Row) Then
          dic1(ini.Row) = Empty             'origin
          'to up
          Call put_arrow(i, j, ini, fin, sh, dic1, dic2, shp, 0.75, 0.25, 1, i - 1, 3, -1)
          'to down
          Call put_arrow(i, j, ini, fin, sh, dic1, dic2, shp, 0.75, 0.75, 0, i + 1, lr, 1)
        End If
      End If
    Next
  Next
  Application.ScreenUpdating = True
End Sub

Sub put_arrow(i, j, ini, fin, sh, dic1, dic2, shp, x, y, z, p, q, r)
  Dim k As Long
  For k = p To q Step r
    Set fin = Cells(k, j + 1)
    If Not dic1.exists(k) Then
      If fin.Value <> "" Then
        If Not dic2.exists(fin.Row) Then
          dic2(fin.Row) = Empty       'destination
          Set shp = sh.Shapes.AddConnector(msoConnectorStraight, _
            ini.Left + (ini.Width * x), ini.Top + (ini.Height * y), _
            fin.Left, fin.Offset(z).Top)
          shp.Line.EndArrowheadStyle = msoArrowheadTriangle
        End If
        Exit For
      End If
    Else
      Exit For
    End If
  Next
End Sub

----- --
Let me know the result and I'll get back to you as soon as I can.
Sincerely
Dante Amor
----- --
 
Upvote 0
Hello DanteAmor,
Thank you for the feedback, both codes work very well and meet my expectations, you will save me time and resolve all the difficulties encountered in developing the arrows for the family tree, I am happy.
Thanks again and congratulations on the work already done.
However, I have a small problem, let me explain:
On the sheet that I am working on, I have command buttons which are placed at the first line of my sheet, I click on these buttons to launch macros according to my needs, moreover, I added and placed a new button to launch and execute your code "Creation_of_arrows", when I click on the command button to launch your macro, the arrows are quickly placed in the desired place and the code works very well, the only small problem is that it removes all my command buttons which are placed at the first line.
Can you look at how we can avoid this, perhaps also see a way to make the control buttons non-movable or even impossible to remove.
Have a nice day and look forward to hearing from you.
I'm also looking to see if I can find a property on the command buttons that allows me to no longer delete them.
 
Upvote 0
Hello DanteAmor,
I looked at your code, it seems to me that the command buttons are removed by the following line of code:
VBA Code: 
   sh.DrawingObjects.delete
Can you target the spot to remove the arrows, why don't we start at line number 2, that way we are sure not to touch the command buttons that are on line number 1.
Thank you for reading.
 
Upvote 0
harzer said:
the only small problem is that it removes all my command buttons
Click to expand...

Try this:

VBA Code: 
Sub Creation_of_arrows()
  Dim lr As Long, lc As Long, i As Long, j As Long
  Dim dic1 As Object, dic2 As Object
  Dim ini As Range, fin As Range
  Dim shp As Shape
  Dim sh As Worksheet
 
  Application.ScreenUpdating = False
 
  Set sh = ActiveSheet
  Set dic1 = CreateObject("Scripting.Dictionary")
  Set dic2 = CreateObject("Scripting.Dictionary")
 
  For Each shp In sh.Shapes
    If shp.ShapeStyle = 10002 Then
      shp.Delete
    End If
  Next
  lr = ActiveSheet.UsedRange.Rows(sh.UsedRange.Rows.Count).Row
  lc = ActiveSheet.UsedRange.Columns(sh.UsedRange.Columns.Count).Column
 
  For j = 1 To lc
    For i = 3 To lr
      If Cells(i, j).Value <> "" Then
        Set ini = Cells(i, j)
        If Not dic1.exists(ini.Row) Then
          dic1(ini.Row) = Empty             'origin
          'to up
          Call put_arrow(i, j, ini, fin, sh, dic1, dic2, shp, 0.75, 0.25, 1, i - 1, 3, -1)
          'to down
          Call put_arrow(i, j, ini, fin, sh, dic1, dic2, shp, 0.75, 0.75, 0, i + 1, lr, 1)
        End If
      End If
    Next
  Next
  Application.ScreenUpdating = True
End Sub

Sub put_arrow(i, j, ini, fin, sh, dic1, dic2, shp, x, y, z, p, q, r)
  Dim k As Long
  For k = p To q Step r
    Set fin = Cells(k, j + 1)
    If Not dic1.exists(k) Then
      If fin.Value <> "" Then
        If Not dic2.exists(fin.Row) Then
          dic2(fin.Row) = Empty       'destination
          Set shp = sh.Shapes.AddConnector(msoConnectorStraight, _
            ini.Left + (ini.Width * x), ini.Top + (ini.Height * y), _
            fin.Left, fin.Offset(z).Top)
          shp.Line.EndArrowheadStyle = msoArrowheadTriangle
        End If
        Exit For
      End If
    Else
      Exit For
    End If
  Next
End Sub

Regards Dante Amor
😇
 
Upvote 0
Solution
Hello DanteAmor,
Thank you for correcting the code, it works well, processing is fast even for a large number of generations.
Without you, it is impossible for me to create a code of the same type, thank you for your availability and your patience and above all for your efficiency.
I'll see you soon maybe for a next request!
Greetings.
 
Upvote 0
You must log in or register to reply here.

Similar threads

T
  • Question
Combination Charts - Office 365
Replies
0
Views
71
tbrynard01
T
H
  • Solved
Count nonblank lines (between blank lines)
2
Replies
15
Views
690
Alex Blakenburg
A
H
  • Solved
Modify content of cells in column "F" according to the content of cells in column "A"
Replies
5
Views
339
igold
igold
H
  • Solved
Count breeding birds by year and sex.
2
Replies
16
Views
876
harzer
H
S
  • Solved
How to separate text out to a new column - Text to Column does not work
Replies
7
Views
553
kevin9999
K

Forum statistics

Threads
1,215,069
Messages
6,122,954
Members
449,095
Latest member
nmaske

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top