Excel VBA Tutorial - Using VBA to show blinking symbol on a Map

 

 

 

My colleague Ms. Chee SK (Google | LinkedIn) conducted an Excel Executive Training for a corporate Singapore-based customer recently. They need to use Excel to indicate which MRT station is the nearest to their customer's location or customer specified landmark. Example, for a landmark called WestMall, the nearest MRT station is Bukit Batok. A symbol shall be displayed and blinking on a MRT map. 

 

I then explore the possibility to use Excel VBA to accomplish this. Here are my work.


1. First, put the map image on a worksheet called Map.
 

2. Select the cell below the map, example cell D15, which is closest to Bukit Batok. Set the Name to "BukitBetok".
 

 

3. Put a graphic. Set the Name to "myoutlet".
 

 

4. You have another worksheet, that have many landmarks, next of the WestMall landmarks, put a hyperlink to jump to named cell "BukitBatok".
 

 

 

 5. Here is fun part. When the cursor is at "BukitBetok" cell due to the hyperlink. We need VBA to detect there is SelectionChange happens. It then check whether the cell has Name. I have Outletname function to check the availability of the Name. If yes, it moves the "myoutlet" symbol to the cell. Plus, we need the symbol to blink few seconds. I have Blinking subroutine to do blinking.


Here is the code in the Map worksheet module.

 

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Select Case Outletname(Target)

Case "BukitBatok"
Worksheets("Map").Shapes("myoutlet").Top = Target.Top
Worksheets("Map").Shapes("myoutlet").Left = Target.Left
Blinking

Case Else
Worksheets("Map").Shapes("myoutlet").Top = Worksheets("Map").Range("T1").Top
Worksheets("Map").Shapes("myoutlet").Left = Worksheets("Map").Range("T1").Left

End Select

End Sub

 

Sub Blinking()

Dim n As Integer
Dim mytime

For n = 1 To 20
Worksheets("Map").Shapes("myoutlet").Visible = Not Worksheets("Map").Shapes("myoutlet").Visible
mytime = Time + 1 / 60 / 60 / 24
'Wait 1 sec.
While mytime > Time
DoEvents
Wend
Next

End Sub

Function Outletname(Target As Range) As String


On Error Resume Next
Dim nm As Name, r As Range

Outletname = ""
For Each nm In Application.Names
Set r = Application.Intersect(Target, Range(nm.Name))
If Not r Is Nothing Then
Outletname = nm.Name
Exit For
End If
Next nm

End Function

 

6. For other MRT stations, you can repeat step 4. And, don't forget also, in the SelectionChange subroutine, add the case clause for the new station.

Case "XXX"
Worksheets("Map").Shapes("myoutlet").Top = Target.Top
Worksheets("Map").Shapes("myoutlet").Left = Target.Left
Blinking

 

By Liang Ee Hang  | Google  | LinkedIn

 

Cempaka Technology Sdn Bhd

Pusat Latihan Komputer Cempaka
~Your HRDC Premiere Training Provider~
64-2, Jalan Puteri 2/2, Bandar Puteri Puchong, 47100 Puchong Selangor, Malaysia. Tel: 603-80684461
1-28, Jalan PM4, Plaza Mahkota, 75000 Melaka. Tel: 606-2835955
Instant SSL