VBA to draw arrows between matching cells which change position

[Uberpixel]

I'm trying to create a VBA script that compares two similar ranges of cells and draws arrows between cells with matching text strings. Think of making a seating chart of names in excel where you want to visually show the necessary moves from one seating chart to the next. I have that working successfully in the script shown in this post which I've pulled together from various scripts posted on the web.

My issue is that I don't want to draw an arrow in the case where the cells match but the relative position in the range doesn't change. Or in other words, for the person who stays in the same seat from one seating chart to the next, I don't want to draw the arrow between those cells.

I'm hoping this just means adding another condition argument but I don't know how to write it.

Any help?

 Sub DrawArrows12()

Dim Rng As Range, Dn As Range

Set Rng = Range(Range("C2"), Range("G16"))

With CreateObject("scripting.dictionary")

.CompareMode = vbTextCompare

For Each Dn In Rng

    If Not IsNumeric(Dn) Then

        If Not .Exists(Dn.Value) Then

            .Add Dn.Value, Dn

    Else

        ActiveSheet.Shapes.AddConnector(msoConnectorStraight, Dn.Left + (Dn.Width / 2), Dn.Top, .Item(Dn.Value).Left + (.Item(Dn.Value).Width / 2), .Item(Dn.Value).Top + (.Item(Dn.Value).Height)).Select

   

    With Selection.ShapeRange.Line

    .BeginArrowheadStyle = msoArrowheadOpen

    .EndArrowheadStyle = msoArrowheadOval

    .Weight = 1.75

    .Transparency = 0.7

    If UCase(LineType) = "DOUBLE" Then 'double arrows

        .BeginArrowheadStyle = msoArrowheadOpen

    ElseIf UCase(LineType) = "LINE" Then 'Line (no arrows)

        .EndArrowheadStyle = msoArrowheadNone

    Else 'single arrow

        'defaults to an arrow with one head

    End If

    'color arrow

    If RGBcolor <> 0 Then

        .ForeColor.RGB = RGBcolor 'custom color

    Else

        .ForeColor.RGB = RGB(228, 108, 10)   'orange (DEFAULT)

    End If

End With

   

    End If

End If

Next

End With

 

 

End Sub

 

[RickXL]

Hi,

Your question says "compares two similar ranges of cells" but the code only points to one range, C2:G16.

I am confused.

 

[Uberpixel]

Hi,

Your question says "compares two similar ranges of cells" but the code only points to one range, C2:G16.

I am confused.

Sorry. The range contains two sets of data. Effectively two different seating charts, one in C2 through G7 and the next C11 through G16. These sets are the same layout but may or may not have different names in each cell.

Right now I believe my code looks for any matches and draws an arrow from the first cell to its match.

I'm wondering if I need to instead set this up to somehow compare two separate arrays of cells. No idea how to do this... This was my effort at hacking together some code I found on the web. Unfortunately I don't know VBA...

Thanks for any help you can offer.

 

[RickXL]

OK, thanks for that, I understand now.

Welcome to the MrExcel Message Board, by the way.

Various possible solutions spring to mind: two ranges, two dictionaries ...

Do you want the seats to have numbers? We may as well get it all sorted out in one go if we can.

Regards ,

 

[Uberpixel]

OK, thanks for that, I understand now.

Welcome to the MrExcel Message Board, by the way.

Various possible solutions spring to mind: two ranges, two dictionaries ...

Do you want the seats to have numbers? We may as well get it all sorted out in one go if we can.

Regards ,

Thanks for the welcome.

Not sure why I was playing coy - I might as well come clean (especially since you're from the UK and therefore probably a soccer fan)... I set it up originally as a seating chart for my example but I'm planning to use it as a soccer lineup planner. I'm a coach and have been using a simpler version to plan my rotations (at this age we are changing lineups every 7 minutes with all kids getting equal playing time)... My current spreadsheet is using conditional formatting for colors and some basic non-VBA code with dynamic drowdowns for each position to show which kids are available from the roster. It determines which kids are on the bench by comparing the roster to the kids selected for each position on the field and also keeps track of when kids are playing back to back shifts and counts total shifts per game to help ensure equal playing time.

It's been working great but where it becomes tricky is when I move a player from forward to defense (or vice-versa) from one shift to the next. I thought scripting the arrows to show that movement would be the simplest way to show the change.

It works fine as is, but it draws the arrows for the kids that are staying on the field and not changing positions. I only want the arrows to show up when the kid stays on the field but moves to a different position. I could just delete the unnecessary arrows after the fact, but what fun is that?

I'd like the code to be flexible so I can use this next year when my team goes from 7v7 to 9v9 and then on to 11v11.

-uberpixel

 

[RickXL]

Thanks for the update. It is making more sense now.

I decided to do it like this:

1. Use two ranges.
2. Read the first range into the dictionary
3. Loop round the second range and spot changes.
4. If there is a change then draw the arrow.

I decided to make the strings defining the ranges constants. These are then placed at the start of the code and are easily changed if necessary.

I added steps to erase all the existing shapes to make re-running the code easier.

I also added a feint green background to the two ranges so that I could see where they were. The code also clears all background colours when it runs to make sure that only the current ranges are selected.

I prefer to give the dictionary a name so that it can be tracked using Watch and Locals - but that is just personal choice.

Instead of logging the cell address in the dictionary item I logged the cell count number. If you use code like this:

    For Each c In Range
        ' ...
    Next

the code will step through the first row of cells then when it gets to the last cell in the row it will step to the next row. SO I just counted the cells as I stepped through. This number can be used to see if the "cell number" has changed or not.

I am not entirely happy with the arrow drawing because I don't know exactly how you want them ot be drawn. I think I might connect the centres of the cells. You also have the LineType parameter that was not set in the code you supplied. Neither was the RGBColor value. So there will be some adjustments required in that area.

The code now looks like this:

Sub DrawArrows12()
    Const r1 As String = "C2:G7"
    Const r2 As String = "C11:G16"
    
    Dim i         As Long
    Dim dic       As Object
    Dim Key       As String
    Dim c         As Range
    Dim sh        As Shape
    Dim LineType  As String
    Dim RGBColor  As Long
    
    Set dic = CreateObject("Scripting.Dictionary")
    
    RGBColor = RGB(0, 0, 0)
    LineType = "line"
    dic.CompareMode = vbTextCompare
    
    Cells.Interior.Color = xlNone
    Range(r1).Interior.Color = RGB(234, 255, 231)
    Range(r2).Interior.Color = RGB(234, 255, 231)
    For Each sh In ActiveSheet.Shapes
        sh.Delete
    Next
    
    i = 0
    For Each c In Range(r1)
        i = i + 1
        dic(c.Value) = i
    Next
    
    i = 0
    For Each c In Range(r2)
        i = i + 1
        Key = c.Value
        If dic.Exists(Key) Then
            If dic(Key) <> i Then
                With ActiveSheet.Shapes.AddConnector(msoConnectorStraight, _
                        Range(r2)(i).Left + (Range(r2)(i).Width / 2), _
                        Range(r2)(i).Top, _
                        Range(r1)(i).Left + (Range(r1)(i).Width / 2), _
                        Range(r1)(i).Top + (Range(r1)(i).Height))
                    With .Line
                        .BeginArrowheadStyle = msoArrowheadOpen
                        .EndArrowheadStyle = msoArrowheadOval
                        .Weight = 1.75
                        .Transparency = 0.7
                        Select Case UCase(LineType)
                            Case "DOUBLE": .BeginArrowheadStyle = msoArrowheadOpen
                            Case "LINE":   .EndArrowheadStyle = msoArrowheadNone
                            Case Else 'single arrow
                        End Select
                        'color arrow
                        If RGBColor <> 0 Then .ForeColor.RGB = RGBColor Else .ForeColor.RGB = RGB(228, 108, 10)
                    End With
                End With
            End If
        End If
    Next
End Sub

 

[Uberpixel]

Thanks. I'll take a look.

-uberpixel

 

[RickXL]

Hi, Apologies.

I tested it last night by swapping two rows of data and the results looked OK. However, if you make more complex changes it does not work.

Please try this instead:

Sub DrawArrows12()
    Const r1 As String = "C2:G7"
    Const r2 As String = "C11:G16"

    Dim i         As Long
    Dim dic       As Object
    Dim Key       As String
    Dim sh        As Shape
    Dim LineType  As String
    Dim RGBColor  As Long
    
    Set dic = CreateObject("Scripting.Dictionary")
    
    RGBColor = RGB(0, 0, 0)
    LineType = "line"
    dic.CompareMode = vbTextCompare
    
    Cells.Interior.Color = xlNone
    Range(r1).Interior.Color = RGB(234, 255, 231)
    Range(r2).Interior.Color = RGB(234, 255, 231)
    
    Cells.Borders.LineStyle = xlNone
    Range(r1).Borders.LineStyle = xlContinuous
    Range(r2).Borders.LineStyle = xlContinuous
    
    For Each sh In ActiveSheet.Shapes: sh.Delete: Next
    
    For i = 1 To Range(r1).Count
        If Range(r1)(i).Value <> "" Then dic(Range(r1)(i).Value) = i
    Next
    
    For i = 1 To Range(r2).Count
        Key = Range(r2)(i).Value
        If dic.Exists(Key) Then
            If dic(Key) <> i Then
                With ActiveSheet.Shapes.AddConnector(msoConnectorStraight, _
                        Range(r2)(i).Left + (Range(r2)(i).Width / 2), _
                        Range(r2)(i).Top, _
                        Range(r1)(dic(Key)).Left + (Range(r1)(dic(Key)).Width / 2), _
                        Range(r1)(dic(Key)).Top + (Range(r1)(dic(Key)).Height))
                    With .Line
                        .BeginArrowheadStyle = msoArrowheadOpen
                        .EndArrowheadStyle = msoArrowheadOval
                        .Weight = 1.75
                        .Transparency = 0.7
                        Select Case UCase(LineType)
                            Case "DOUBLE": .BeginArrowheadStyle = msoArrowheadOpen
                            Case "LINE":   .EndArrowheadStyle = msoArrowheadNone
                            Case Else 'single arrow
                        End Select
                        'color arrow
                        If RGBColor <> 0 Then .ForeColor.RGB = RGBColor Else .ForeColor.RGB = RGB(228, 108, 10)
                    End With
                End With
            End If
        End If
    Next
End Sub

I simplified the loops and added some borders to the coloured areas to save me doing it manually.
By the way, if you do not like these extra features remember, the Delete key is your friend.
The main fix was to change the indices used for one end of the arrows.

It might be worth explaining that:

Const r1 As String = "C2:G7"
Range(r1)(i).Value

actually means:

ActiveSheet.Range("C2:G7").Cells(i).Value

where i is the number of the cell counting along rows in turn.

1	2	3	4	5
6	7	8	9	10
11	12	13	14	15
16	17	18	19	20
21	22	23	24	25
26	27	28	29	30

<tbody>
</tbody>

Regards,

 

[Uberpixel]

Hmm... Not really working with my setup. I think I've left out too much information regarding my layout. I'm attaching a screenshot of the current behavior with my code. The names of the players on the field are selected from drop down lists and the bench is calculated using some IF statements. I'd like to get rid of the vertical arrows that show up when a player stays on the field in the same position from shift to shift. Ideally, the remaining arrows would follow a specific path depending on the start cell and finish cell to avoid writing over the top of another cell, but this seems like it is probably too much work to be worth the trouble.

Each position's color changes from green to orange to red as the player plays back to back shifts (conditional formatting) so the green background you've introduced is not desirable. Also, your code is deleting my action buttons.

The in/out section is an attempt to show which player is in for which player going out from shift to shift. This is a bit confusing and is at the heart of what I'm trying to improve with the arrows.

The numbers below the names are each players rating at that position allowing me to get a score for each lineup.

Hope this helps clarify what I'm doing and what I'd like to do.

 

[RickXL]

OK, so I have removed my additions because clearly, I don't know what I am actually adding to.

I have converted the macro into one that can be called from another macro. The other macro will supply the range details so no need for the Const values.

Sub AllArrows()
          
    Call DrawArrows12("C2:G9", "C11:G18")
    Call DrawArrows12("C11:G18", "C20:G27")
    Call DrawArrows12("C20:G27", "C29:G36")
    
    Call DrawArrows12("N2:R9", "N11:R18")
    Call DrawArrows12("N11:R18", "N20:R27")
    Call DrawArrows12("N20:R27", "N29:R36")

End Sub

This calls the following, revised code:

Sub DrawArrows12(ByVal r1 As String, ByVal r2 As String)
    Dim i         As Long
    Dim dic       As Object
    Dim Key       As String
    Dim LineType  As String
    Dim RGBColor  As Long
    
    Set dic = CreateObject("Scripting.Dictionary")
    
    RGBColor = RGB(0, 0, 0)
    LineType = "line"
    dic.CompareMode = vbTextCompare
    
    For i = 1 To Range(r1).Count
        If Not IsNumeric(Range(r1)(i).Value) Then dic(Range(r1)(i).Value) = i
    Next
    
    For i = 1 To Range(r2).Count
        Key = Range(r2)(i).Value
        If dic.Exists(Key) Then
            If dic(Key) <> i Then
                With ActiveSheet.Shapes.AddConnector(msoConnectorStraight, _
                        Range(r2)(i).Left + (Range(r2)(i).Width / 2), _
                        Range(r2)(i).Top, _
                        Range(r1)(dic(Key)).Left + (Range(r1)(dic(Key)).Width / 2), _
                        Range(r1)(dic(Key)).Top + (Range(r1)(dic(Key)).Height))
                    With .Line
                        .BeginArrowheadStyle = msoArrowheadOpen
                        .EndArrowheadStyle = msoArrowheadOval
                        .Weight = 1.75
                        .Transparency = 0.7
                        Select Case UCase(LineType)
                            Case "DOUBLE": .BeginArrowheadStyle = msoArrowheadOpen
                            Case "LINE":   .EndArrowheadStyle = msoArrowheadNone
                            Case Else 'single arrow
                        End Select
                        'color arrow
                        If RGBColor <> 0 Then .ForeColor.RGB = RGBColor Else .ForeColor.RGB = RGB(228, 108, 10)
                    End With
                End With
            End If
        End If
    Next
End Sub

Let me know how you get on.

Regards,