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,

 

[BrettFoster]

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

This worked, but for one page. I even toyed with the ranges on the other pages. I'm going to fool around with a bit on the other pages (change the formats etc to match the original, and then try again).

Thank you so much for spending the time you have helping me with this. It'll be a phenomenal help to the organization that I work for to have such a tool as this, because it'll save a tremendous amount of time.

Regards,

PS If there is a way to offset the lines by half cell to the right of the H column and half of a cell left of the M column, that would also be helpful. If not, I'll make a macro that moves the data from my truncated I and L columns to the opposite sides of the text data.

Again thanks,

Brett

 

[BrettFoster]

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

I matched formats on all pages, and your solution now works like a charm. Thank you so much for this.

Kind regards,
Brett