VBA - Draw line to next high value

Hi, I would appreciate some coding help from all experts in here.
I'm about to analyze our picking operations and all positions have an identifier so the picker
picks the articles in correct order. So my idea is to analyze if the picking route is correctly set up.

so in order to simplify it i would like to draw lines between all positions in correct order.
For instance,

First line between Position 1 to 2
Second line from position 2 to 3

So I would like the macro to draw the line to the next high value and sometime it could be from 6-8 because 7 is
not specified.

i found this code earlier but it draw only lines between equal values.

Code:

---

Sub drawline()
Dim Rng As Range, Dn As Range
Set Rng = Range(Range("A1"), Range("d" & Rows.Count).End(xlUp))
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
For Each Dn In Rng
 If IsNumeric(Dn) Then
 If Not .Exists(Dn.Value) Then
 .Add Dn.Value, Dn
 Else
 ActiveSheet.Shapes.AddLine(Dn.Left + (Dn.Width / 3), Dn.Top + (Dn.Height / 3), _
.Item(Dn.Value).Left + (.Item(Dn.Value).Width / 3), .Item(Dn.Value).Top _
+ (.Item(Dn.Value).Height / 3)).Select
 End If
End If
Next
End With
End Sub

---

Code:

---

Option Explicit

Sub test()
    Dim c As Range
    Dim i As Long
    Dim B As Range, E As Range
   
    ActiveSheet.Shapes.SelectAll
    Selection.Delete
   
    With CreateObject("system.collections.sortedlist")
        For Each c In Range("A1").CurrentRegion
            If c.Value <> "" Then .Item(c.Value) = c
        Next
        For i = 0 To .Count - 2
            Set B = .GetByIndex(i)
            Set E = .GetByIndex(i + 1)
           
            ActiveSheet.Shapes.AddLine _
                    B.Left + (B.Width / 3), _
                    B.Top + (B.Height / 3), _
                    E.Left + (E.Width / 3), _
                    E.Top + (E.Height / 3)
        Next
    End With
   
End Sub

---

Super thanks mana!
Works as expected, only feature i might missing now is to allow spaces (empty cells) in both directions.

Like picture below.
Attachment 17086
so the VBA search for next number.

Code:

---

Sub test2()
    Dim c As Range
    Dim i As Long
    Dim B As Range, E As Range
   
    ActiveSheet.Shapes.SelectAll
    Selection.Delete
   
    With CreateObject("system.collections.sortedlist")
        For Each c In ActiveSheet.UsedRange
            If c.Interior.ColorIndex <> xlNone Then
                If c.Value <> "" Then .Item(c.Value) = c
            End If
        Next
        For i = 0 To .Count - 2
            Set B = .GetByIndex(i)
            Set E = .GetByIndex(i + 1)
           
            ActiveSheet.Shapes.AddLine _
                B.Left + (B.Width / 3), _
                B.Top + (B.Height / 3), _
                E.Left + (E.Width / 3), _
                E.Top + (E.Height / 3)
        Next
    End With
   
End Sub

---