Option Explicit
Sub CreateTabularData()
'Errors may occur if any inputs contain a comma
Dim lLastRow As Long
Dim oIDFound As Object
Dim lOutputStartRow As Long
Dim lWriteRow As Long
Dim lRowIndex As Long
Dim sText As String
lOutputStartRow = 3
With ActiveSheet
.Cells(lOutputStartRow, 3).Resize(1, 8).Value = _
Array("ID", "Name", "Audience Size", "Interests", _
"Additional Interest", "Type", "Description", "Topic")
lWriteRow = lOutputStartRow
lLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("C:J").NumberFormat = "@"
For lRowIndex = 2 To lLastRow
sText = .Cells(lRowIndex, 1).Text
If InStr(sText, "id:") > 0 Then
lWriteRow = lWriteRow + 1
.Cells(lWriteRow, 3).Value = Replace(Replace(Mid(sText, 6), Chr(34), ""), ",", "")
ElseIf InStr(sText, "name:") > 0 Then
.Cells(lWriteRow, 4).Value = Replace(Replace(Mid(sText, 8), Chr(34), ""), ",", "")
ElseIf InStr(sText, "audience_size: ") > 0 Then
.Cells(lWriteRow, 5).Value = Replace(Mid(sText, 16), ",", "")
ElseIf InStr(sText, "Interests,") > 0 And Len(sText) = 10 Then
If InStr(.Cells(lRowIndex + 1, 1).Text, "Additional interests,") = 0 Then
.Cells(lWriteRow, 6).Value = Replace(.Cells(lRowIndex + 1, 1).Text, ",", "")
End If
ElseIf InStr(sText, "description: ") > 0 Then
.Cells(lWriteRow, 9).Value = Replace(Replace(Mid(sText, 14), Chr(34), ""), ",", "")
ElseIf InStr(sText, "topic: ") > 0 Then
.Cells(lWriteRow, 10).Value = Replace(Mid(sText, 9), Chr(34), "")
End If
Next
End With
End Sub