PDA

View Full Version : VBA - Draw line to next high value



johanssson
09-15-2016, 12:33 AM
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.

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

mana
09-15-2016, 03:31 AM
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

johanssson
09-15-2016, 04:07 AM
Super thanks mana!
Works as expected, only feature i might missing now is to allow spaces (empty cells) in both directions.

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

mana
09-15-2016, 06:40 AM
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