If you are open to a VBA solution, it is relatively straightforward, although the code is somewhat complex.
Algorithm depends on:
- Phone being the only optional componenet
- All components are in a fixed order
- No empty rows
- loop through the data
- always extract the first three as name, company, email
- test the fourth line and see if it starts with a
+ or a
- if it does, store it as the phone and the four as a line in the dictionary
- if not store the previous three as a line in the dictionary
For convenience, intelligibility and speed
- I created a class object to hold the data
- I created a dictionary to hold the different class objects
- I used regular expressions to decide if the optional phone number entry matched the pattern
- I used VBA arrays rather than working directly on the worksheet as this is about 10x faster.
To enter this Macro (Sub), alt-F11 opens the Visual Basic Editor.
Ensure your project is highlighted in the Project Explorer window.
Then, from the top menu, select Insert/Module or Insert/Class Module and
paste the appropriate code below into the window that opens.
Make the appropriate edits in the code if your worksheet names and desired ranges are not as you want. The code assumes your data source starts in
Sheet1 and that the results will start on
Be sure to set the appropriate references as mentioned in the comments at the top of the regular module
Tools/References and select them
To use this Macro (Sub), opens the macro dialog box. Select the macro by name, and RUN.
Private pName As String
Private pCompany As String
Private pEmail As String
Private pPhone As Variant
Public Property Get Name() As String
Name = pName
Public Property Let Name(Value As String)
pName = Value
Public Property Get Company() As String
Company = pCompany
Public Property Let Company(Value As String)
pCompany = Value
Public Property Get Email() As String
Email = pEmail
Public Property Let Email(Value As String)
pEmail = Value
Public Property Get Phone() As Variant
Phone = pPhone
Public Property Let Phone(Value As Variant)
pPhone = Trim(CStr(Value))
'Set Reference to Microsoft Scripting Runtime
'set reference to Microsoft Regular Expressions 5.5
Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
Dim vSrc As Variant, vRes As Variant
Dim cD As cData, dD As Dictionary
Dim RE As RegExp
Dim IDX As Long
Dim I As Long, key As Variant
Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet2")
Set rRes = wsRes.Cells(1, 1)
vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
Set dD = New Dictionary
Set RE = New RegExp
.Pattern = "\s*[+\d]"
.Global = False
For I = 1 To UBound(vSrc, 1)
If I = 1 Then
Set cD = New cData
IDX = 0
.Name = vSrc(I, 1)
.Company = vSrc(I + 1, 1)
.Email = vSrc(I + 2, 1)
If I + 3 > UBound(vSrc, 1) Then Exit For
If RE.Test(vSrc(I + 3, 1)) Then
.Phone = vSrc(I + 3, 1)
I = I + 3
I = I + 2
IDX = IDX + 1
dD.Add key:=IDX, Item:=cD
Set cD = New cData
ReDim vRes(0 To dD.Count, 1 To 4)
vRes(0, 1) = "Name"
vRes(0, 2) = "Company"
vRes(0, 3) = "Email"
vRes(0, 4) = "Phone"
For Each key In dD.Keys
vRes(key, 1) = .Name
vRes(key, 2) = .Company
vRes(key, 3) = .Email
vRes(key, 4) = .Phone
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
.Columns(4).NumberFormat = "@"
.Value = vRes
'add the hyperlinks
Dim c As Range
For Each c In .Columns(3).Cells
If InStr(c.Text, "@") > 0 Then
c.Hyperlinks.Add c, c.Text
.Style = "Output"