VBA – A Search Algorithm with VBA – Teil Zwei

Posted on September 20, 2015 by

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

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

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

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

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

If cell_current.Column < C_COLUMNS Then

Set my_cell = cell_current.Offset(0, 1)