Sub test()
Dim a, e, b(), n As Long, x, w(), t As Long, z As String
Dim myTitle As String, myWord, myCount, myDensity
With Range("a1", Range("a" & Rows.Count).End(xlUp))
a = .Value
ReDim b(1 To UBound(a, 1) * 2, 1 To Columns.Count)
With Createobject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For Each e In a
If InStr(1, e, "Not", 1) > 0
x = Trim(Split(e, "in")(1))
myTitle = Trim(Left$(x, InStrRev(e, "(") - 1))
myWord = Val(Mid$(e, InStrRev(e, "(") + 1))
myCount = 0
myDensity = 0
Else
x = Split(Split(e, " ", 8)(7), "(")(0)
z = Replace(Trim(Left$(x, InStrRev(x, " "))), "words", "",,,1)
myTitle = Trim(Left$(x, InStrRev(e, "(") - 1))
myWord = Val(Split(e, " in ")(1))
myCount = Val(Split(e)(3))
myDensity = Val(Replace(Split(e, "Density: ")(1),"%","")) & "%"
End If
If Not .exists(z) Then
t = t + 3 : b(1, t - 2) = myTitle & " Words"
b(1, t - 1) = myTitle & " Count" : b(1, t) = myTitle & " Density"
.item(z) = VBA.Array(2, t)
End If
w = .item(z)
b(w(0), w(1) - 2) = myWord : b(w(0), w(1) - 1) = myCount
b(w(0), w(1)) = myDensity : w(0) = w(0) + 1
.item(z) = w
maxRow = Application.Max(maxRow, w(0))
Next
End With
.Offset(, 2).Resize(maxRow, t).Value = b
End With
End Sub
Bookmarks