VBA – A* search algorithm with Excel – Really?

Posted on September 17, 2015 by

Today, some hours ago I saw the implementation of the A* search algorithm with Java, made by a classmate (or colleague) of mine. It looks like this:

Thus, I have thought that for the reading of the Python Algorithm book, it may be a good idea to remember how algorithms were made 🙂 Thus, instead of using Python, which makes a lot of things easy, provides outstanding and easy to use lists, dictionaries and anything a VBA programmer may dream of, I have decided to make a tribute to the good old VBA.

Before continuing, I remember that I have not mentioned the Hack Bulgaria Conference in Sofia, so I have to fix this bug a little. If by any chance you are going to Sofia on 18.09.2015 then this is a must-see! 🙂

Back to the VBA. So, what did I do? At first I have started to go around the net to see whether someone has something similar. Nothing similar with VBA was found at the first page of the Google results, thus I have decided to dedicate my evening for this. (Actually two evenings, as far as at the end I have somehow deleted the code).

So, I have been able at the end to provide the following beautiful picture of the A* path finding:

So, how does it work? You “create” the obstacles in the path finder with simply selecting the cells, which you want to be obstacles. Then you start the macro, and it sets automatically the start and end points on the two corners (red is start, green is end). In order to set different dimensions for the labyrinth, you may adjust the two constant values for C_COLUMNS and C_ROWS.

I have decided not to use arrays, because I do not like the way Excel treats them (true story), thus the whole data for the “cost” of the possible achieving of the result, plus the “parent” cell were simply written in the excel file within the cell.

Thus, the visualization was better. 🙂 At the end, once the path was found, I simply went back, coloring the “parents” of the cell.

The code has really plenty of points for improvement:

Its size can be really made 2-3 times less;
I have to make the font colors in the same color as the background colors
The A* implementation can be improved. It does not select the best path always, I am aware of it. This is because I am ignoring the rule, that the diagonal cells cost 14 units and the straight cells cost just 10. When I have time, I will fix it. Or not.

Pretty much that is it. And the funny moment now – as far as I was really tired yesterday, when I was writing this article, somehow I have forgotten to save the Excel as *.xlsm and I have lost the code. Thus, I have decided to recode it today 🙂 Yup, the only more insane thing than writing A* algorithm with Excel is writing it twice.

But now I have the code, plus 2-3 nice pictures. Here they are:

The start (walls are simply selection in Excel – you know, press control)

The A* is running

The End

So, pretty much that is all. Here comes the code of the app and the app itself (I would not download a script file from any internet site, thus think twice before doing so) and the GitHub code.

Option Explicit

Public Const C_COLUMNS = 60
Public Const C_ROWS = 20

Public cell_start       As Range
Public cell_end         As Range

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
    
    Call Reset
    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
    
End Sub

Public Sub Reset()
    
    Dim sName As String
    
    Cells.Delete
    Range(Cells(1, 1), Cells(C_ROWS, C_COLUMNS)).Name = "Playground"
    
    Set cell_start = Cells(1, 1)
    Set cell_end = Cells(C_ROWS, C_COLUMNS)

    [playground].Style = "Neutral"
    [playground].RowHeight = 14
    [playground].ColumnWidth = 2.3
    [playground].WrapText = True
    
    
    Call MakeProblems
    
    cell_start.Style = "Bad"
    cell_end.Style = "Good"
    
End Sub
Public Sub AdvertiseHere()

    Range(Cells(C_ROWS + 1, 1), Cells(C_ROWS + 1, C_COLUMNS)).Merge
    Range(Cells(C_ROWS + 1, 1), Cells(C_ROWS + 1, C_COLUMNS)) = "Vitoshacademy.com!"
    Range(Cells(C_ROWS + 1, 1), Cells(C_ROWS + 1, C_COLUMNS)).HorizontalAlignment = xlCenter
    
End Sub
Public Sub MakeProblems()
    
    Selection.Style = "Accent1"

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)
    End If
    
End Function

Public Sub ColorNeighbours(cell_current)

End Sub

Public Function distance_to_success(my_cell As Range) As Long
    
    distance_to_success = Abs(my_cell.Row - cell_end.Row) + Abs(my_cell.Column - cell_end.Column)
    
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 Split(my_cell, "*")(1) < l_result Then
                l_result = Split(my_cell, "*")(1)
                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

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

Option Explicit

Public Const C_COLUMNS = 60

Public Const C_ROWS = 20

Public cell_start As Range

Public cell_end As Range

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

Call Reset

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

End Sub

Public Sub Reset()

Dim sName As String

Cells.Delete

Range(Cells(1, 1), Cells(C_ROWS, C_COLUMNS)).Name = "Playground"

Set cell_start = Cells(1, 1)

Set cell_end = Cells(C_ROWS, C_COLUMNS)

[playground].Style = "Neutral"

[playground].RowHeight = 14

[playground].ColumnWidth = 2.3

[playground].WrapText = True

Call MakeProblems

cell_start.Style = "Bad"

cell_end.Style = "Good"

End Sub

Public Sub AdvertiseHere()

Range(Cells(C_ROWS + 1, 1), Cells(C_ROWS + 1, C_COLUMNS)).Merge

Range(Cells(C_ROWS + 1, 1), Cells(C_ROWS + 1, C_COLUMNS)) = "Vitoshacademy.com!"

Range(Cells(C_ROWS + 1, 1), Cells(C_ROWS + 1, C_COLUMNS)).HorizontalAlignment = xlCenter

End Sub

Public Sub MakeProblems()

Selection.Style = "Accent1"

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

If cell_current.Column < C_COLUMNS Then

Set my_cell = cell_current.Offset(0, 1)