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

 

[Uberpixel]

Let me know how you get on.

Regards,

Thanks. I'll give it a try tonight. I'm realizing now that I should have mentioned that my not so elegant implementation had separate (but identical) scripts to analyze each shift change (thus the Drawarrows12 nomenclature - I also had Drawarrows23, 34, 56, 67, and 78). I was just calling all of them from a base script with the button. Looks like you figured that out from my attached image. Sorry if that caused any confusion.

Thanks again for all of your help. I'm looking forward to trying this tonight.

-uberpixel

 

[Uberpixel]

So, that works great and is a much cleaner way of drawing the arrows, but... It reproduces exactly the same outcome as my original code.

Now if we could get it to stop drawing the arrows between position when the player doesn't change, it would be perfect.

I've attached an image of the desired outcome...

-uberpixel

 

[RickXL]

I will take a look ...

 

[RickXL]

That is exactly what mine looks like.

 

[Uberpixel]

That is exactly what mine looks like.

Okay. I'll try it again - could be I didn't clear out my old code or something...

 

[RickXL]

Are you deleting any previous arrows before you run the code?

I have just created a new workbook by copying and pasting the worksheet from the old work book and copying the code from this thread and it seems to be working.

The critical line in the code is this one:

If dic(Key) <> i Then

That says draw an arrow only if the cell number in the previous area is different from the cell number in the current area.

 

[Uberpixel]

Got it.

Works perfectly now. Had to clean up my Module names and the button that was launching the draw arrows script.

Thanks for your help. I'll have to see if I can learn how the code drives the results by reverse engineering what you've done.

-uberpixel

 

[RickXL]

There are some details in earlier posts. It basically works just like your original code except:

1. It keeps the different ranges separate.
2. Instead of noting the cell address it logs the cell number as described in post #8.

The business part of the code is just this:

    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
            
                ' Draw Arrow
                
            End If
        End If
    Next

The first loop selects the cells of interest and records the cell number in the dictionary against the name.
The second loop cycles round the second range. It then finds the matching name, if any, if the cell number is different then the cell has changed so the arrow is drawn.
The Range(r1)(i).Value syntax is explained earlier as well.