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
So we
- 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 digit
- 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 A1 on Sheet1 and that the results will start on A1 on Sheet2
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.
Class Module
Option Explicit
Private pName As String
Private pCompany As String
Private pEmail As String
Private pPhone As Variant
Public Property Get Name() As String
Name = pName
End Property
Public Property Let Name(Value As String)
pName = Value
End Property
Public Property Get Company() As String
Company = pCompany
End Property
Public Property Let Company(Value As String)
pCompany = Value
End Property
Public Property Get Email() As String
Email = pEmail
End Property
Public Property Let Email(Value As String)
pEmail = Value
End Property
Public Property Get Phone() As Variant
Phone = pPhone
End Property
Public Property Let Phone(Value As Variant)
pPhone = Trim(CStr(Value))
End Property
Regular Module
'Set Reference to Microsoft Scripting Runtime
'set reference to Microsoft Regular Expressions 5.5
Option Explicit
Sub dataTable()
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)
With wsSrc
vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
Set dD = New Dictionary
Set RE = New RegExp
With RE
.Pattern = "\s*[+\d]"
.Global = False
End With
For I = 1 To UBound(vSrc, 1)
If I = 1 Then
Set cD = New cData
IDX = 0
End If
With cD
.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
Else
I = I + 2
End If
IDX = IDX + 1
dD.Add key:=IDX, Item:=cD
End With
Set cD = New cData
Next I
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
With dD(key)
vRes(key, 1) = .Name
vRes(key, 2) = .Company
vRes(key, 3) = .Email
vRes(key, 4) = .Phone
End With
Next key
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
.EntireColumn.Clear
.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
End If
Next c
.Style = "Output"
.EntireColumn.AutoFit
End With
End Sub
Original Data
Processed Data
