Извлечение рисунка из колонки

Question

Я борюсь с огромным листом Excel (с 200K строк), где мне нужно извлечь из определенного столбца (B) список всех адресов электронной почты, присутствующих в строке.

То, что я хочу добиться:

1. Извлечение электронной почты из строки
2. новообращенного (at) к @ и (dot) в .
3. Сохранить имя и адрес электронной почты в отдельных столбцах

Пример колонка B:

Shubhomoy Biswas <biswas_shubhomoy777(at)yahoo(dot)com> 
Puneet Arora <ar.puneetarora(at)gmail(dot)com> 
Anand Upadhyay <001.anand(at)gmail(dot)com> 
Rajat Gupta <rajatgupta0889(at)gmail(dot)com> 
Sarvesh Sonawane <sarvesh.s(at)suruninfocoresystems. 

Хотя я хочу, чтобы это можно было сделать в Excel, было бы полезно использовать любое другое предложение на основе Windows.

Answer 1

это можно сделать при условии, что они находятся в том же формате, и только 1 электронная почта добавить в ячейку

= подставим (SUBSTITUTE (MID (B1, FIND ("<", B1) + 1, LEN (B1) -FIND ("<", B1) -1), "(at)", "@"), "(dot)", ".")

Answer 2

Дайте этому попытку:

Sub splitter() 
    Dim r As Range, v As String 

    For Each r In Intersect(Range("B:B"), ActiveSheet.UsedRange) 
     v = r.Text 
     If v <> "" Then 
     ary = Split(v, " <") 
     r.Offset(0, 1).Value = ary(0) 
     r.Offset(0, 2).Value = Replace(Replace(Replace(ary(1), ">", ""), "(at)", "@"), "(dot)", ".") 
     End If 
    Next r 
End Sub 

Эта подпрограмма использует столбцы C и D для выхода. Измените код, чтобы удовлетворить ваши потребности.

Answer 3

Чтобы извлечь имя, попробуйте TRIM (LEFT (B1, FIND ("<", B1) -1)). Ответ пользователя3005775 работает на электронную почту.

Answer 4

Вы также можете сделать это легко регулярное выражение (вам нужно добавить ссылку на Microsoft VBScript регулярных выражений):

Private Sub ExtractEmailInfo(value As String) 

    Dim expr As New RegExp 
    Dim result As Object 
    Dim user As String 
    Dim addr As String 

    expr.Pattern = "(.+)(<.+>)" 
    Set result = expr.Execute(value) 
    If result.Count > 0 Then 
     user = result(0).SubMatches(0) 
     addr = result(0).SubMatches(1) 
     'Strip the <and> 
     addr = Mid$(addr, 2, Len(addr) - 2) 
     addr = Replace$(addr, "(at)", "@") 
     addr = Replace$(addr, "(dot)", ".") 
    End If 

    Debug.Print user 
    Debug.Print addr 

End Sub 

Замените Debug.Print вызовы с тем, что вам нужно сделать, чтобы разместить их в клетки.

Answer 5

Это делает его на 200 К строк менее чем за 15 секунд:

Option Explicit 

Sub extractPattern() 
    Dim ws As Worksheet, ur As Range, rng As Range, t As Double 
    Dim fr As Long, fc As Long, lr As Long, lc As Long 

    Set ws = Application.ThisWorkbook.Worksheets("Sheet1") 
    Set ur = ws.UsedRange 
    fr = 1 
    fc = 1 
    lr = ws.Cells(ur.Row + ur.Rows.Count + 1, fc).End(xlUp).Row 
    lc = ws.Cells(fr, ur.Column + ur.Columns.Count + 1).End(xlToLeft).Column 

    Set rng = ws.Range(ws.Cells(fr, fc), ws.Cells(lr, fc)) 

    enableXL False 
    t = Timer 
    rng.TextToColumns Destination:=ws.Cells(fr, lc + 1), DataType:=xlDelimited, _ 
         TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, _ 
         Space:=True 
    With ws.Columns(lc + 3) 
     .Replace What:="(at)", Replacement:="@", LookAt:=xlPart 
     .Replace What:="(dot)", Replacement:=".", LookAt:=xlPart 
     .Replace What:="<", Replacement:=vbNullString, LookAt:=xlPart 
     .Replace What:=">", Replacement:=vbNullString, LookAt:=xlPart 
    End With 
    ws.Range(ws.Cells(fr, lc + 1), ws.Cells(fr, lc + 3)).EntireColumn.AutoFit 
    Debug.Print "Total rows: " & lr & ", Duration: " & Timer - t & " seconds" 
    enableXL 'Total rows: 200,000, Duration: 14.4296875 seconds 
End Sub 

Private Sub enableXL(Optional ByVal opt As Boolean = True) 
    Application.ScreenUpdating = opt 
    Application.EnableEvents = opt 
    Application.Calculation = IIf(opt, xlCalculationAutomatic, xlCalculationManual) 
End Sub 

---

Он помещает новые данные в первом неиспользованном столбце в конце (расщепляет имена, а)