正規表現を使えばある程度は抽出可能かと思います。
以下は別シートに出力する例です。
電話番号は4列目の先頭のものを抽出、メールアドレスは4列目の後方のものを抽出するようにしています。
提示されている例には対応できているかと思いますが、これ以外のフォーマットになると調整が必要です。
VBA
1Sub test()
2 Dim RE
3 Dim r As Long
4
5 Set RE = CreateObject("VBScript.RegExp")
6 Set srcsh = ActiveSheet
7 Set newsh = Worksheets.Add
8 r = 1
9
10 While srcsh.Cells(r, 1) <> ""
11 ' 会社名
12 newsh.Cells(r, 1).Value = srcsh.Cells(r, 2).Value
13 ' 名前
14 newsh.Cells(r, 2).Value = srcsh.Cells(r, 3).Value
15 ' 電話番号
16 With RE
17 .Pattern = "^(0\d+-\d+-\d+)"
18 .Global = True
19 Set reMatch = .Execute(srcsh.Cells(r, 4).Value)
20 End With
21 If reMatch.Count > 0 Then
22 If reMatch(0).SubMatches.Count > 0 Then
23 newsh.Cells(r, 3).Value = reMatch(0).SubMatches(0)
24 End If
25 End If
26 ' メールアドレス
27 With RE
28 .Pattern = "([A-Za-z][\w-]+@[\w-]+.[\w-.]+).*$"
29 .Global = True
30 Set reMatch = .Execute(srcsh.Cells(r, 4).Value)
31 End With
32 If reMatch.Count > 0 Then
33 If reMatch(0).SubMatches.Count > 0 Then
34 newsh.Cells(r, 4).Value = reMatch(0).SubMatches(0)
35 End If
36 End If
37 r = r + 1
38 DoEvents
39 Wend
40 Set RE = Nothing
41
42End Sub
43