VBA on cell change, search for similar value and fetch contact details?

Question

I have three worksheets:

Contacts

Column A (Supplier Name)    Column B      Column C
Mars                        Name          Email
Marstons
General Mills
General UK

Data

Cell I2

Delivery Tracker

Column E (Supplier Name)

Mars
...
...

Basically i've built a VBA code, that once a supplier name has been typed in column E on delivery tracker sheet, the code searches for a similar matching supplier name from column A on Contacts sheet. It then pulls up the matching contact number, email and fax for that supplier name.

It then places these contact details in cell I2 on Data sheet.

A shape object is then displayed on delivery tracker sheet pulling through these contact details from cell I2.

Here is my code:

'Start Phone Book Directory Code
Dim Contact As String
Dim Email As String
Dim Phone As String
Dim Fax As String

Application.EnableEvents = False 'to prevent endless loop
On Error GoTo Finalize 'to re-enable the events

If Not Intersect(Target, ThisWorkbook.Worksheets(1).Range("F" & ActiveCell.Row)) Is Nothing Then 'Main IF
ThisWorkbook.Worksheets(1).Shapes("Suggest").Visible = False
ThisWorkbook.Worksheets(1).Shapes("Close").Visible = False
Application.EnableEvents = True
'ActiveSheet.Unprotect Password:="SecretPassword"
Else
If ThisWorkbook.Worksheets(1).Range("E" & ActiveCell.Row).Value = "" Or ThisWorkbook.Worksheets(1).Range("F" & ActiveCell.Row).Value <> "" Then ' Secondary iF
ThisWorkbook.Worksheets(1).Shapes("Suggest").Visible = False
ThisWorkbook.Worksheets(1).Shapes("Close").Visible = False
Application.EnableEvents = True
'ActiveSheet.Unprotect Password:="SecretPassword"
Else


    'Start FIND
Dim c As Variant

With Worksheets("Contacts").Range("A1:A10000")
Set c = .Find("*" & ActiveCell.Offset(0, -1).Value & "*", LookIn:=xlValues)
If c Is Nothing Then

'Introduce FailSafe, escape code if no result found
ThisWorkbook.Worksheets(1).Shapes("Suggest").Visible = False
ThisWorkbook.Worksheets(1).Shapes("Close").Visible = False
'ActiveSheet.Unprotect Password:="SecretPassword"


Else

'Check values are not blank
If c.Offset(0, 1).Value <> "" Then
Contact = "Contact: " & c.Offset(0, 1).Value & Chr(10)
Else
Contact = "Contact: No Contact Held" & Chr(10)
End If

If c.Offset(0, 2).Value <> "" Then
Email = "Email: " & c.Offset(0, 2).Value & Chr(10)
Else
Email = "Email: No Email Held" & Chr(10)
End If

If c.Offset(0, 3).Value <> "" Then
Phone = "Phone: " & c.Offset(0, 3).Value & Chr(10)
Else
Phone = "Phone: No Phone Held" & Chr(10)
End If

If c.Offset(0, 4).Value <> "" Then
Fax = "Fax: " & c.Offset(0, 4).Value
Else
Fax = "Fax: No Fax Held"
End If


'Show Contacts
ThisWorkbook.Worksheets("Data").Range("I2").Value = "Hello," & vbNewLine & "Have you tried to contact " & c.Value & " about your issue?" & vbNewLine _
& Contact & Email & Phone & Fax

'ThisWorkbook.Worksheets(1).Shapes("Suggest").TextFrame.AutoSize = True
CenterShape ThisWorkbook.Worksheets(1).Shapes("Suggest")
RightShape ThisWorkbook.Worksheets(1).Shapes("Close")
ThisWorkbook.Worksheets(1).Shapes("Suggest").Visible = True

'Show Close Button
ThisWorkbook.Worksheets(1).Shapes("Close").Visible = True






End If
End With

End If ' End Main If
End If ' End Secondary If



'Error Handling

Finalize:
Application.EnableEvents = True

This works, except If the user types in Mars then contact details for Marstons is shown.

This is wrong. The code needs to use wildcards because sometimes the user may type Mars Ltd or Mars Uk and this should match Mars (but not Marstons)

Please can someone show me a better way of doing this?