metin içinden mail adresini çekmek

[ermanusta]

excelde ortalama 4000 satır bilgi mevcut

A1 hücresinden başlayarak

Hücre - içerik:
A1-http://www.kurumsalmarket.com/
A2-RMA Gıda Ambalaj ve Temizlik
A3-Telefon No: 0216 451 70 02 E-Posta: info@kurumsalmarket.com
A4-http://www.marvelmate.com/
A5-telefon 216 465 76 78 e-mail info@marvelmate.com
A6-bilgi
...
...
...

Şeklinde A4000 hücresine kadar belirli belirsiz düzende yazılmış şirket bilgileri var.

Yapmak istediğim bu şirket bilgileri içerisinden, bana sadece mail adresini çekip çıkarabilecek bir makro .

 

[snx111]

Function ExtractEmailAddress(s As String) As String
    Dim AtSignLocation As Long
    Dim i As Long
    Dim TempStr As String
    Const CharList As String = "[A-Za-z0-9._-]"
    
    'Get location of the @
    AtSignLocation = InStr(s, "@")
    If AtSignLocation = 0 Then
        ExtractEmailAddress = "" 'not found
    Else
        TempStr = ""
        'Get 1st half of email address
        For i = AtSignLocation - 1 To 1 Step -1
            If Mid(s, i, 1) Like CharList Then
                TempStr = Mid(s, i, 1) & TempStr
            Else
                Exit For
            End If
        Next i
        If TempStr = "" Then Exit Function
        'get 2nd half
        TempStr = TempStr & "@"
        For i = AtSignLocation + 1 To Len(s)
            If Mid(s, i, 1) Like CharList Then
                TempStr = TempStr & Mid(s, i, 1)
            Else
                Exit For
            End If
        Next i
    End If
    'Remove trailing period if it exists
    If Right(TempStr, 1) = "." Then TempStr = _
       Left(TempStr, Len(TempStr) - 1)
    ExtractEmailAddress = TempStr
End Function

formul olarak

 

[ermanusta]

formul olarak derken durumu anlayamadım kusura bakmayın makrolar konusunda baya bi acemiyim,

sizin verdiğiniz bu kodları yeni bir makro olarak kaydettim ancak çalıştıramadım, acaba formul olarak nasıl çalıştırabilirim excell 2003 kullanıyorum

 

[Levent Menteşoğlu]

Aşağıdaki kodu deneyin. Mail adreslerini B sütununa yazar.

Sub mailadresial()
Set deg = CreateObject("VBScript.Regexp")
deg.Pattern = "[a-zA-Z0-9\-_.]{2,}@[a-zA-Z0-9\-]{2,}.[a-zA-Z0-9\-]{2,6}$"
deg.Global = True
For a = 1 To [a65536].End(3).Row
Set veri = deg.Execute(Cells(a, "a"))
If veri.Count > 0 Then Cells(a, "b") = veri.Item(0)
Next
End Sub

 

[ermanusta]

Levent Menteşoğlu

çok teşekkür ederim, tam istediğim gibi oldu. elinize bilginize sağlık.

 

[snx111]

Sub mail_adresini_e_stununa_aktar()
Dim x As Range
Dim son_sat As Long
Dim bul_sat As Long
Dim ik As Long
Dim aranan As Long
Const CharList As String = "[A-Za-z0-9._-]"
son_sat = Sayfa1.Cells(Rows.Count, 1).End(3).Row

For Each x In Range("a1:a" & son_sat)
aranan = InStr(x, "@")
bul_sat = x.Row
Set Rng = Range("a" & bul_sat)

If aranan > 1 Then Rng.Copy Destination:=Range("e" & x.Row)

Next


End Sub

çeşit makro olarak mail bulununan satırı e ye kopyalar

 

[snx111]

Sub mail_bul()
Dim AtSignLocation As Long
    Dim i As Long
    Dim tempstr As String
    Const CharList As String = "[A-Za-z0-9._-]"
    Dim x As Range
Dim son_sat As Long
Dim bul_sat As Long
Dim ik As Long
Dim aranan As Long
 
son_sat = Sayfa1.Cells(Rows.Count, 1).End(3).Row
 
For Each x In Range("a1:a" & son_sat)
aranan = InStr(x, "@")
bul_sat = x.Row
If aranan > 1 Then 'tempstr.Copy Destination:=Range("e" & x.Row)
        'Get 1st half of email address
        For i = aranan - 1 To 1 Step -1
            If Mid(x, i, 1) Like CharList Then
                tempstr = Mid(x, i, 1) & tempstr
            Else
                Exit For
            End If
    Next i
    If tempstr = "" Then Exit Sub
        'get 2nd half
        tempstr = tempstr & "@"
        For i = aranan + 1 To Len(x)
            If Mid(x, i, 1) Like CharList Then
                tempstr = tempstr & Mid(x, i, 1)
            Else
                Exit For
            End If
        Next i
    End If
    'Remove trailing period if it exists
    If Right(tempstr, 1) = "." Then tempstr = _
       Left(tempstr, Len(tempstr) - 1)
    Range("e" & x.Row) = tempstr
     tempstr = ""
    Next
End Sub

makro olarak yazdım ama levent bey benden biraz daha önce davranmış ;bazı eksikleri olmasına rağmen; hemde daha kısa pratik çözmüş