Drawing Arrows Macro For Matching Cells

[BrettFoster]

Hi,

The issue that I need help with is as follows: let's say I have a cell in column H labeled Analyze Issues. In column M, I have the same cell. I want create a macro that draws an arrow from Analyze Issues in column H to the the matching cell in column M.

This macro works:

Sub MG11Jan25()
Dim Rng As Range, Dn As Range
Set Rng = Range(Range("H3"), Range("M" & Rows.Count).End(xlUp))
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.AddLine(Dn.Left + (Dn.Width / 2), Dn.Top + (Dn.Height / 2), .Item(Dn.Value).Left + (.Item(Dn.Value).Width / 2), .Item(Dn.Value).Top + (.Item(Dn.Value).Height / 2)).Select
End If
End If
Next
End With
End Sub

However, there are two problems: I need the lines it draws to not attach to the center of the cells, but at the right end of the cells in H and at the left end of the cells in column M. Furthermore, I would like the lines to be a little offset from the end of the cells, or with a little distance between the cells edge and and the end of the arrow/line.

Regards,

 

[Andrew Poulsom]

Like this?

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

 

[BrettFoster]

Andrew,

Thank you so much for your quick response to this issue.

I added the code you provided in place of the corresponding code I listed above. This solution is actually very very close at solving the problem; however, of all the drawn lines your improvement provided several lines still attach to the the wrong ends of cells; by that, I mean, the incorrect lines attach to the far left of the H column and then to the far right of the M column. I'm trying to get all lines attached to the far right of H and the far left of M. If possible, even, have the lines draw about half a cells width away, toward the M or H columns, respectively, so as to not cover my truncated I and L columns (but if this isn't possible or worth the time, I can work with just the first solution).

Regards,

Brett

 

[Andrew Poulsom]

With Analyse Issues in H3 and M3, my code drew a line from the right of H3 to the left of M3. Please post some sample date where it doesn't work.

 

[BrettFoster]

With Analyse Issues in H3 and M3, my code drew a line from the right of H3 to the left of M3. Please post some sample date where it doesn't work.

I don't see how to attach a file here. So, I'll just write it out.

cH r. r. cM A U B T C S D R E Q F O G N H M I L J K K J L I M H N G O F P <tbody> </tbody> Q
R
S T U

<tbody>
</tbody>

I'm not very apt with the formatting options here, and I'm pressed for time, so. A-U in column H. U-A in column M (it makes a nice vanishing point in the center). I checked, and your macro works fine when cells are perfectly aligned across from one another, but when they are mixed as my example, some are not how I need them be.

I hope this was explanatory enough. And sorry I couldn't attach a file.

Regard

 

[Andrew Poulsom]

Try:

                    If Dn.Column = 13 Then
                       ActiveSheet.Shapes.AddLine(Dn.Left, Dn.Top + (Dn.Height / 2), .Item(Dn.Value).Left + .Item(Dn.Value).Width, .Item(Dn.Value).Top + (.Item(Dn.Value).Height / 2)).Select
                    Else
                       ActiveSheet.Shapes.AddLine(.Item(Dn.Value).Left, .Item(Dn.Value).Top + (.Item(Dn.Value).Height / 2), Dn.Left + Dn.Width, Dn.Top + (Dn.Height / 2)).Select
                    End If

 

[BrettFoster]

Try:

                    If Dn.Column = 13 Then
                       ActiveSheet.Shapes.AddLine(Dn.Left, Dn.Top + (Dn.Height / 2), .Item(Dn.Value).Left + .Item(Dn.Value).Width, .Item(Dn.Value).Top + (.Item(Dn.Value).Height / 2)).Select
                    Else
                       ActiveSheet.Shapes.AddLine(.Item(Dn.Value).Left, .Item(Dn.Value).Top + (.Item(Dn.Value).Height / 2), Dn.Left + Dn.Width, Dn.Top + (Dn.Height / 2)).Select
                    End If

I amended my code to:

Sub MG11Jan25()
Dim Rng As Range, Dn As Range
Set Rng = Range(Range("H3"), Range("M" & Rows.Count).End(xlUp))
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
If Dn.Column = 13 Then
ActiveSheet.Shapes.AddLine(Dn.Left, Dn.Top + (Dn.Height / 2), .Item(Dn.Value).Left + .Item(Dn.Value).Width, .Item(Dn.Value).Top + (.Item(Dn.Value).Height / 2)).Select
Else
ActiveSheet.Shapes.AddLine(.Item(Dn.Value).Left, .Item(Dn.Value).Top + (.Item(Dn.Value).Height / 2), Dn.Left + Dn.Width, Dn.Top + (Dn.Height / 2)).Select
End If
End If
Next
End With
End Sub

I'm getting error with the Next above. The error says "Compile Error Next without For"

Thanks again.

 

[BrettFoster]

Try:

                    If Dn.Column = 13 Then
                       ActiveSheet.Shapes.AddLine(Dn.Left, Dn.Top + (Dn.Height / 2), .Item(Dn.Value).Left + .Item(Dn.Value).Width, .Item(Dn.Value).Top + (.Item(Dn.Value).Height / 2)).Select
                    Else
                       ActiveSheet.Shapes.AddLine(.Item(Dn.Value).Left, .Item(Dn.Value).Top + (.Item(Dn.Value).Height / 2), Dn.Left + Dn.Width, Dn.Top + (Dn.Height / 2)).Select
                    End If

Looks like I was missing an "End If"

I added it:

Sub MG11Jan25()
Dim Rng As Range, Dn As Range
Set Rng = Range(Range("H3"), Range("M" & Rows.Count).End(xlUp))
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
        If Dn.Column = 13 Then
            ActiveSheet.Shapes.AddLine(Dn.Left, Dn.Top + (Dn.Height / 2), .Item(Dn.Value).Left + .Item(Dn.Value).Width, .Item(Dn.Value).Top + (.Item(Dn.Value).Height / 2)).Select
    Else
            ActiveSheet.Shapes.AddLine(.Item(Dn.Value).Left, .Item(Dn.Value).Top + (.Item(Dn.Value).Height / 2), Dn.Left + Dn.Width, Dn.Top + (Dn.Height / 2)).Select
End If
    End If
        End If
Next
End With
End Sub

This time, the arrows are drawn straight through the width of the cells; for example, from far left of column H, a line is drawn to the far right of column H, etc. It's the same with M.

 

[BrettFoster]

Any ideas on how to fix this? It looks like the lines are striking out the cells.

 

[Andrew Poulsom]

This is the full code, which works for me with the sample data you posted:

Sub MG11Jan25()
    Dim Rng As Range, Dn As Range
    Set Rng = Range(Range("H3"), Range("M" & Rows.Count).End(xlUp))
    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
                    If Dn.Column = 13 Then
                       ActiveSheet.Shapes.AddLine(Dn.Left, Dn.Top + (Dn.Height / 2), .Item(Dn.Value).Left + .Item(Dn.Value).Width, .Item(Dn.Value).Top + (.Item(Dn.Value).Height / 2)).Select
                    Else
                       ActiveSheet.Shapes.AddLine(.Item(Dn.Value).Left, .Item(Dn.Value).Top + (.Item(Dn.Value).Height / 2), Dn.Left + Dn.Width, Dn.Top + (Dn.Height / 2)).Select
                    End If
                End If
            End If
        Next
    End With
End Sub