Connect cells with lines - fixing gaps

[adakos]

Hi!
I'm using the following code to connect the cells that contain the letter "o" and nothing else.

I have a range that is a homemade graph and I want it to all be connected and made pretty.

The following code works when there are no gaps in the lines, however, if there is a gap in the lines for some reason the line will stop.

How can i modify this to draw the lines from each "o" to the next even if there is a gap?

(I'm pretty sure the "If rngFrom Is Nothing" then line is screwing me up but I'm stumped....)

Private Sub CommandButton3_Click()
'figure out if the cells have what i need
'if so call the draw function to connect them

    Dim rngTo As Range
    Dim rngFrom As Range
    Dim rngCol As Range
    
    For Each rngCol In Range("$B$3:$AF$33").Columns
        For Each rngTo In rngCol.Cells
            If rngTo = "o" Then
                If rngFrom Is Nothing Then
                    Set rngFrom = rngTo
                Else
                    DrawLine rngTo, rngFrom
                End If
                Exit For
            End If
        Next
        Set rngFrom = rngTo
    Next
    

End Sub

Sub DrawLine(FromCell As Range, ToCell As Range)
     'draw lines! and make them pretty
    With FromCell.Parent.Shapes.AddLine(1, 1, 1, 1)
        If FromCell.Left > ToCell.Left Then
            .Left = ToCell.Left + (ToCell.Width / 2)
            .Width = (FromCell.Left + (FromCell.Width / 2)) - .Left
        Else
            .Left = FromCell.Left + (FromCell.Width / 2)
            .Width = (ToCell.Left + (ToCell.Width / 2)) - .Left
        End If
        If FromCell.Top > ToCell.Top Then
            .Top = ToCell.Top + (ToCell.Height / 2)
            .Height = (FromCell.Top + (FromCell.Height / 2)) - .Top
        Else
            .Top = FromCell.Top + (FromCell.Height / 2)
            .Height = (ToCell.Top + (ToCell.Height / 2)) - .Top
            .Flip msoFlipVertical
        End If
        .Line.Weight = 2
        .Line.ForeColor.SchemeColor = 3
    End With
     
End Sub

 

[adakos]

Hate to bump myself, but does anyone have any clue?

 

[jimrward]

hi

i have changed your core loop a bit, try the following

Private Sub CommandButton3_Click()
'figure out if the cells have what i need
'if so call the draw function to connect them

Dim rngTo As Range
Dim rngFrom As Range
Dim rngCol As Range

For Each rngCol In Range("$B$3:$AF$33").Columns
For Each rngTo In rngCol.Cells
If rngTo = "o" Then
If rngFrom Is Nothing Then
Set rngFrom = rngTo
Else
DrawLine rngTo, rngFrom
Set rngFrom = rngTo
End If
End If
Next

Next


End Sub

 

[adakos]

You became my hero! thanks so much. I see what you did there =) thanks!

 

[jimrward]

i did also tried another method of selection just to get all of the used cells, but it returns the cells in a different manner and paints lines all over the place, see below, but you have the correct selection, just the chaining of cells was not right

Sub jim2()
'figure out if the cells have what i need
'if so call the draw function to connect them

Dim rngTo As Range
Dim rngFrom As Range
Dim rngCol As Range

Set rrange = Range("$B$3:$M$20").SpecialCells(xlCellTypeConstants, xlTextValues)
For Each rcell In rrange
If rcell.Value = "o" Then
If rngFrom Is Nothing Then
Set rngFrom = rcell
Else
Set rngTo = rcell
DrawLine rngTo, rngFrom
Set rngFrom = rngTo
End If
End If
Next
End Sub