Sub SplitData()
Dim shtData As Worksheet
Dim arrSplitCat As Variant
Dim arrSplitDetail
Dim lr As Long, i As Long, j As Long
Dim rngData As Range, arrData As Variant, rngOut As Range, arrOut As Variant
Dim iEmail As Long
Set shtData = ActiveSheet
With shtData
lr = .Range("AF" & Rows.Count).End(xlUp).Row
Set rngData = .Range(.Cells(2, "AF"), .Cells(lr, "AF"))
arrData = rngData
Set rngOut = .Cells(2, "AG")
End With
ReDim arrOut(1 To UBound(arrData), 1 To 5)
For i = 1 To UBound(arrData)
iEmail = 1
arrSplitCat = Split(arrData(i, 1), ";")
For j = 0 To UBound(arrSplitCat)
arrSplitDetail = Split(arrSplitCat(j), ":")
Select Case Trim(arrSplitDetail(0))
Case "Email"
If iEmail < 3 Then
arrOut(i, iEmail) = Trim(arrSplitDetail(1))
iEmail = iEmail + 1
End If
Case "Facebook"
arrOut(i, 3) = Trim(arrSplitDetail(1))
Case "Instagram"
arrOut(i, 4) = Trim(arrSplitDetail(1))
Case "Web"
arrOut(i, 5) = Trim(arrSplitDetail(1))
Case Else
' do nothing
End Select
Next j
Next i
Set rngOut = rngOut.Resize(UBound(arrOut, 1), UBound(arrOut, 2))
With rngOut
.FormulaR1C1 = arrOut
.Columns.AutoFit
End With
Dim rCell As Range
For Each rCell In rngOut.Resize(, 2)
shtData.Hyperlinks.Add anchor:=rCell, Address:="mailto:" & rCell.Value
Next rCell
For Each rCell In rngOut.Offset(, 2).Resize(rngOut.Rows.Count, rngOut.Columns.Count - 2)
shtData.Hyperlinks.Add anchor:=rCell, Address:="http://" & rCell.Value
Next rCell
End Sub
