VBA – A Search Algorithm with VBA – Teil Zwei
After the article here I have started to think more over the search algorithm and I have decided to make it look better and work better. E.g., by using the fact, that the distance between the diagonals neighbours is 1.4 times more the distance of the direct neighbour tiles. This comes from the Pythagorean Theorem and could be easily proven. To speed up my code, I have decided to make it 140 and 100 instead of 1.4 and 1, because my processor is better at this kind of maths 🙂
Furthermore, I have added the possibility to generate obstacles by random and by selection. Another feature is the fact, that you may design the matrix size by your own.
And pretty much that is all so far.
Here are the screenshots (the blue cells are from selection, the greens are from random):
Here comes the code:
Option Explicit
Public C_COLUMNS As Long
Public C_ROWS As Long
Public cell_start As Range
Public cell_end As Range
Public Sub SetColsAndRows()
C_COLUMNS = tbl_matrix.tb_cols
C_ROWS = tbl_matrix.tb_rows
End Sub
Public Sub Main()
Dim cell_current As Range
Dim l_smallest_path As Long
Dim l_col As Long
Dim l_C_ROWS As Long
On Error GoTo Main_Error
Call ObstaclesFromSelect
Call SetColsAndRows
Call SetCellStart
Set cell_current = cell_start
Do While True
If check_for_success(cell_current) Then Exit Do
Set cell_current = find_possible_smallest_path(cell_current)
cell_current.Style = "Input"
Loop
Do While True
cell_current.Style = "Accent2"
If check_for_success(cell_current, False) Then Exit Do
Set cell_current = Range(Split(cell_current, "*")(0))
Loop
Call AdvertiseHere
Set cell_start = Nothing
Set cell_end = Nothing
Set cell_current = Nothing
On Error GoTo 0
Exit Sub
Main_Error:
MsgBox "No Way", vbOKOnly, "No Way"
Debug.Print "Error " & Err.Number & " (" & Err.Description & ") in procedure Main of Module mod_main"
End Sub
Public Sub ObstaclesFromSelect()
Dim r_intersect As Object
Set r_intersect = Application.intersect(Selection, [Playground])
If Not tbl_matrix.cb_obstacles Then
If Not r_intersect Is Nothing Then
r_intersect.Style = "Accent1"
End If
End If
Set r_intersect = Nothing
End Sub
Public Sub SetCellStart()
Set cell_start = Cells(1, 2)
Set cell_end = Cells(C_ROWS, C_COLUMNS)
End Sub
Public Sub Reset()
Dim sName As String
Dim rCell As Range
Call SetColsAndRows
Call SetCellStart
Cells.Clear
Range(Cells(1, 2), Cells(C_ROWS, C_COLUMNS)).Name = "Playground"
[Playground].Style = "Neutral"
[Playground].RowHeight = 14
[Playground].ColumnWidth = 2.3
[Playground].WrapText = True
Call ObstaclesFromSelect
Call MakeProblems
cell_start.Style = "Bad"
cell_end.Style = "Good"
End Sub
Public Sub AdvertiseHere()
Range(Cells(C_ROWS + 1, 2), Cells(C_ROWS + 1, C_COLUMNS)).Merge
Range(Cells(C_ROWS + 1, 2), Cells(C_ROWS + 1, C_COLUMNS)) = "Vitoshacademy.com!"
Range(Cells(C_ROWS + 1, 2), Cells(C_ROWS + 1, C_COLUMNS)).HorizontalAlignment = xlCenter
End Sub
Public Sub MakeProblems()
Dim dbl_row As Double
Dim dbl_col As Double
Dim dbl_counter As Variant
Dim r_cell As Range
dbl_counter = tbl_matrix.tb_obstacles
While dbl_counter > 0
dbl_row = Int((C_ROWS - 2 + 1) * Rnd + 2)
dbl_col = Int((C_COLUMNS - 2 + 1) * Rnd + 2)
If dbl_row + dbl_col <> 3 And dbl_row + dbl_col <> C_ROWS + C_COLUMNS Then
Set r_cell = Cells(dbl_row, dbl_col)
r_cell.Style = "Accent3"
End If
dbl_counter = dbl_counter - 1
Wend
Set r_cell = Nothing
End Sub
Public Function check_for_success(ByRef cell_current As Range, Optional b_going_back As Boolean = True) As Boolean
Dim my_cell As Range
'3
If cell_current.Column < C_COLUMNS Then
Set my_cell = cell_current.Offset(0, 1)
check_for_success = ChangeCellData(my_cell, b_going_back, cell_current)
If check_for_success Then Exit Function
End If
'4.5
If cell_current.Column < C_COLUMNS And cell_current.Row < C_ROWS Then
Set my_cell = cell_current.Offset(1, 1)
check_for_success = ChangeCellData(my_cell, b_going_back, cell_current)
If check_for_success Then Exit Function
End If
'6
If cell_current.Row < C_ROWS Then
Set my_cell = cell_current.Offset(1, 0)
check_for_success = ChangeCellData(my_cell, b_going_back, cell_current)
If check_for_success Then Exit Function
End If
'7.5
If cell_current.Column > 1 And cell_current.Row < C_ROWS Then
Set my_cell = cell_current.Offset(1, -1)
check_for_success = ChangeCellData(my_cell, b_going_back, cell_current)
If check_for_success Then Exit Function
End If
'9
If cell_current.Column > 1 Then
Set my_cell = cell_current.Offset(0, -1)
check_for_success = ChangeCellData(my_cell, b_going_back, cell_current)
If check_for_success Then Exit Function
End If
'11.5
If cell_current.Column > 1 And cell_current.Row > 1 Then
Set my_cell = cell_current.Offset(-1, -1)
check_for_success = ChangeCellData(my_cell, b_going_back, cell_current)
If check_for_success Then Exit Function
End If
'12
If cell_current.Row > 1 Then
Set my_cell = cell_current.Offset(-1, 0)
check_for_success = ChangeCellData(my_cell, b_going_back, cell_current)
If check_for_success Then Exit Function
End If
'1.5
If cell_current.Column < C_COLUMNS And cell_current.Row > 1 Then
Set my_cell = cell_current.Offset(-1, 1)
check_for_success = ChangeCellData(my_cell, b_going_back, cell_current)
If check_for_success Then Exit Function
End If
Set my_cell = Nothing
End Function
Public Function ChangeCellData(ByRef my_cell As Range, ByRef b_going_back As Boolean, cell_current As Range) As Boolean
If my_cell.Style = IIf(b_going_back, "Good", "Bad") Then ChangeCellData = True
If my_cell.Style = "Neutral" Then
my_cell.Style = "Calculation"
my_cell = cell_current.Address & "*" & distance_to_success(my_cell) & "*" & price_to_reach(my_cell, cell_current) & "*" & distance_to_success(my_cell) + price_to_reach(my_cell, cell_current)
End If
End Function
Public Function price_to_reach(ByRef my_cell, ByRef cell_current) As Double
Dim d_diagonal_1 As Double
Dim d_diagonal_2 As Double
Dim d_diagonal_difference As Double
Dim l_straight_difference As Double
d_diagonal_1 = Abs(my_cell.Row - cell_current.Row)
d_diagonal_2 = Abs(my_cell.Column - cell_current.Column)
d_diagonal_difference = Application.WorksheetFunction.Min(d_diagonal_1, d_diagonal_2)
l_straight_difference = Abs(Abs(my_cell.Row - cell_current.Row) + Abs(my_cell.Column - cell_current.Column))
l_straight_difference = l_straight_difference - 2 * d_diagonal_difference
price_to_reach = l_straight_difference * 10 + d_diagonal_difference * 14
If Not cell_current = "" Then
price_to_reach = price_to_reach + Split(cell_current, "*")(2)
End If
End Function
Public Function distance_to_success(my_cell As Range) As Double
Dim d_diagonal_1 As Double
Dim d_diagonal_2 As Double
Dim d_diagonal_difference As Double
Dim l_straight_difference As Double
d_diagonal_1 = Abs(my_cell.Row - cell_end.Row)
d_diagonal_2 = Abs(my_cell.Column - cell_end.Column)
d_diagonal_difference = Application.WorksheetFunction.Min(d_diagonal_1, d_diagonal_2)
l_straight_difference = Abs(Abs(my_cell.Row - cell_end.Row) + Abs(my_cell.Column - cell_end.Column))
l_straight_difference = l_straight_difference - 2 * d_diagonal_difference
distance_to_success = l_straight_difference * 10 + d_diagonal_difference * 14
End Function
Public Function find_possible_smallest_path(ByRef current_cell As Range) As Range
Dim my_cell As Range
Dim my_result_cell As Range
Dim l_result As Long
l_result = 1000000000
Set my_result_cell = Nothing
For Each my_cell In [Playground]
If my_cell.Style = "Calculation" Then
If CDbl(Split(my_cell, "*")(1)) + CDbl(Split(my_cell, "*")(2)) < l_result Then
l_result = CDbl(Split(my_cell, "*")(1)) + CDbl(Split(my_cell, "*")(2))
Set my_result_cell = my_cell
End If
End If
Next my_cell
Set find_possible_smallest_path = my_result_cell
Set my_result_cell = Nothing
End Function
The file is here – matrix reloaded – Do not download files with VBA code from the Internet! It is not safe!
That’s all 😀