Isolate First Word of Multiple Paragraphs

[VB-AN-IZ]

What's the simplest macro for isolating the first word or cell from each paragraph, and removing everything else from the document? I need this for a list of names - as in, this:

Joe Blow
John Doe

...would become:

Joe
John

I recorded a really idiotic macro that separated each space into a separate column, then copied/pasted just the first column. But it doesn't always work, and I'm sure there's an easier way...



Selection.WholeStory
Application.DefaultTableSeparator = " "
Selection.ConvertToTable Separator:=wdSeparateByDefaultListSeparator, _
NumColumns:=5, NumRows:=45, AutoFitBehavior:=wdAutoFitFixed
With Selection.Tables(1)
.Style = "Table Grid"
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
End With
Selection.HomeKey Unit:=wdStory
Selection.HomeKey Unit:=wdRow
Selection.EndKey Unit:=wdColumn, Extend:=True
Selection.Copy
Selection.WholeStory
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.PasteAndFormat (wdFormatPlainText)
Selection.WholeStory
Selection.Sort ExcludeHeader:=False, FieldNumber:="Paragraphs", _
SortFieldType:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending, _
FieldNumber2:="", SortFieldType2:=wdSortFieldAlphanumeric, SortOrder2:= _
wdSortOrderAscending, FieldNumber3:="", SortFieldType3:= _
wdSortFieldAlphanumeric, SortOrder3:=wdSortOrderAscending, Separator:= _
wdSortSeparateByTabs, SortColumn:=False, CaseSensitive:=False, LanguageID _
:=wdEnglishAUS, SubFieldNumber:="Paragraphs", SubFieldNumber2:= _
"Paragraphs", SubFieldNumber3:="Paragraphs"
Selection.HomeKey Unit:=wdStory
End Sub

[gmaxey]

Sub ScratchMacro()
Dim orng As Range
Dim oPar As Paragraph
For Each oPar In ActiveDocument.Paragraphs
Set orng = oPar.Range
With orng.Find
.Text = "( ?{1,})(^13)"
.MatchWildcards = True
While .Execute
orng.End = orng.End - 1
orng.Delete
orng.Collapse wdCollapseEnd
Wend
End With
Next
lbl_Exit:
Exit Sub
End Sub

[mana]

Sub test()
Dim i As Long
Dim p As Paragraph
Dim s As String


With ActiveDocument
For i = 1 To .Paragraphs.Count
With .Paragraphs(i).Range
s = Trim(.Words(1))
If s <> vbCr Then .Text = s & vbCr
End With
Next
End With

End Sub




Sub test2()
Dim aryl As Object
Dim p As Paragraph
Dim s As String

Set aryl = CreateObject("System.Collections.ArrayList")

For Each p In ActiveDocument.Paragraphs
s = Trim(p.Range.Words(1))
If s <> vbCr Then aryl.Add s
Next

With Documents.Add
.Range.Text = Join(aryl.toarray, vbCr)
End With

End Sub