Копирование email адреса из строки

[NooDle]

Добрый день. Столкнулся с таким заданием. В приложенном файле, нужно скопировать из строки только e-mail адрес, в отдельный столбец. То есть из столбца A, все e-mail адреса перенести в столбец C.

Есть макрос, которой с помощью регулятивного выражения из строки с адресом вытаскивает индекс. Вот как он выглядит. Нужно, что-то вроде этого.

Sub Index()

    CurrentRow = 2 'начальная строка
    EndRow = 50 'конечная строка
    CellValue = ""
    
    AddressColumn = "a" ' столбец с адресом
    PostalCodeColumn = "b" ' столбец куда будет переноситься индекс(6 знаков)
    
Dim oMatches, oMatch
    Dim RegEx As Object
    Set RegEx = CreateObject("vbscript.regexp")

    While CurrentRow <= EndRow
    
        CellValue = CStr(Cells(CurrentRow, AddressColumn).Value)
        
        With RegEx
            .Global = False
            .IgnoreCase = True
            
            .Pattern = "^(\d{6})[^\d]|[^\d](\d{6})[^\d]|[^\d](\d{6})$"
        
             .MultiLine = True
             
   
        End With
        
        If RegEx.Test(CellValue) Then
            Set oMatches = RegEx.Execute(CellValue)
            Set oMatch = oMatches(0)
             Cells(CurrentRow, PostalCodeColumn).Value = "'" & _
                IIf(IsEmpty(oMatch.SubMatches(0)), IIf(IsEmpty(oMatch.SubMatches(1)), oMatch.SubMatches(2), oMatch.SubMatches(1)), oMatch.SubMatches(0)) 'oMatch.SubMatches(0)
             CellValue = RegEx.Replace(CellValue, " ")
        Else
            Cells(CurrentRow, PostalCodeColumn).Value = ""
        End If
            
           
        Cells(CurrentRow, AddressColumn).Value = CellValue
        
        CurrentRow = CurrentRow + 1
      
        
    Wend


End Sub

[EducatedFool]

Вот весь макрос:

Sub test()
    Application.ScreenUpdating = False: Dim cell As Range
    For Each cell In ActiveSheet.UsedRange.EntireRow.Columns(1).Cells
        cell.Offset(, 5) = GetEMail(cell.Value)
    Next
    ActiveSheet.Columns(6).AutoFit
End Sub

Function GetEMail(ByVal txt As String) As String
    txt = Replace(txt, ",", ", ")
    posDOG = InStrRev(txt, "@", , vbTextCompare): If posDOG = 0 Then Exit Function
    posSPACE = InStrRev(txt, " ", posDOG, vbTextCompare): If posSPACE = 0 Then Exit Function
    GetEMail = Mid$(txt, posSPACE + 1)
End Function

Посмотрите вложение:

[IgorGO]

или формулами...

[cent]

Сообщение от IgorGO

или формулами...

Браво! Не перестаю удивляться возможностям Excel и Вашими знаниями в области его формул

[NooDle]

Сообщение от EducatedFool

Вот весь макрос:

Sub test()
    Application.ScreenUpdating = False: Dim cell As Range
    For Each cell In ActiveSheet.UsedRange.EntireRow.Columns(1).Cells
        cell.Offset(, 5) = GetEMail(cell.Value)
    Next
    ActiveSheet.Columns(6).AutoFit
End Sub

Function GetEMail(ByVal txt As String) As String
    txt = Replace(txt, ",", ", ")
    posDOG = InStrRev(txt, "@", , vbTextCompare): If posDOG = 0 Then Exit Function
    posSPACE = InStrRev(txt, " ", posDOG, vbTextCompare): If posSPACE = 0 Then Exit Function
    GetEMail = Mid$(txt, posSPACE + 1)
End Function

Посмотрите вложение:

Спасибо огромное, то что надо!

[NooDle]

Сообщение от IgorGO

или формулами...

Гениально! Ни зачто бы не доудмался формулой вытащить email!!!!!