Change email address to hyperlink w/Macro

**dkub** · 05-26-2011, 11:07 AM

I have a workbook with several sheet within and in column ther may or may not be e-mail addresses. If there is an e-mail address I want to make it hyperlink ready, I don't want to follow it or execute just make it available to be clicked on. I have some code that I am using to loop through the book and it's sheets.

Sub Workbook_CheckEmail()
    
    Dim Thiswb As Workbook      ' Workbook in
    Dim wks As Worksheet
    Dim rngCheck As Range          ' Input Sheet w/data
    Dim MySheet As String
    Dim MySheetCount As Integer
    Dim dtRow As Long

    Application.ScreenUpdating = False

    Set Thiswb = ActiveWorkbook
    Set rngCheck = Range("C1:C255")
    MySheetCount = 0
    dtRow = 2

    For Each ws In ThisWorkbook.Worksheets
    MySheet = ws.Name
        Do Until dtRow > 255
            If ws.Range("C" & dtRow).Value Like "*@*" Then
                ws.Range("C" & dtRow).Hyperlink(1) = True
            Else
            End If
        dtRow = dtRow + 1
        Loop
    MySheetCount = MySheetCount + 1
    Next ws
    
    If MySheetCount = 0 Then
        Debug.Print "No Cell Found !!!"
    Else
    End If
    
    
    Application.ScreenUpdating = True
    
End Sub

Hope this help someone that can help me - thanks in advance

**tigeravatar** · 05-26-2011, 11:52 AM

dkub,

Give this a try:

Sub Workbook_CheckEmail()
    
    Dim wbActive As Workbook:   Set wbActive = ActiveWorkbook
    Dim rngCheck As String:     rngCheck = "C1:C255"
    Dim EmailCount As Long:     EmailCount = 0
    Dim ws As Worksheet, ThisCell As Range
    
    Application.ScreenUpdating = False
    
    For Each ws In wbActive.Worksheets
        For Each ThisCell In ws.Range(rngCheck)
            If InStr(1, ThisCell.Value, "@", vbTextCompare) > 0 Then
                ActiveSheet.Hyperlinks.Add Anchor:=ThisCell, _
                                           Address:="mailto:" & ThisCell.Value, _
                                           TextToDisplay:=ThisCell.Value
                EmailCount = EmailCount + 1
            End If
        Next ThisCell
    Next ws
    
    If EmailCount = 0 Then Debug.Print "No Cell Found !!!"
    
    Application.ScreenUpdating = True
    
End Sub

Hope this helps,
~tigeravatar

**Leith Ross** · 05-26-2011, 11:53 AM

Hello dkub,

I made a few changes to macro to add the hyperlinks for email addresses.

Sub Workbook_CheckEmail()
    
    Dim Ccell As Range
    Dim Thiswb As Workbook      ' Workbook in
    Dim wks As Worksheet
    Dim rngCheck As Range          ' Input Sheet w/data
    Dim MySheet As String
    Dim MySheetCount As Integer

    Application.ScreenUpdating = False

    Set Thiswb = ActiveWorkbook
    MySheetCount = 0
    dtRow = 2

    For Each ws In ThisWorkbook.Worksheets
      MySheet = ws.Name
      Set rngCheck = ws.Range("A1:A255")
        
        For Each Cell In rngCheck
          If Cell.Value Like "*@*.*" Then
             ws.Hyperlinks.Add Anchor:=Cell, Address:="emailto:" & Cell.Value
          End If
        Next Cell
        
      MySheetCount = MySheetCount + 1
    Next ws
    
    If MySheetCount = 0 Then
        Debug.Print "No Cell Found !!!"
    End If
    
    Application.ScreenUpdating = True
    
End Sub