Macro to move the last word of a sentence to the beginning of a line

[menteith]

Hi all!

What I would like to achieve is to have a macro that would move the last word in each line of the selected area to the beginning of a line. Additionally, a comma and a space should be added to the last word. Here is an example of such an area:


John Smith
John Anderson Smith
John A. Smith
J.A. Smith

The macro should do change this area into:


Smith, John
Smith, John Anderson
Smith, John A.
Smith, J.A.

As you may have noticed, I would like to have a macro that would make compiling bibliography easier.

What I tried did first was to clean each line of text so that any not needed characters (double spaces, tabs, double new line characters) would be deleted. My code *seems* to work on a a declared string

strSample = " This is a sample string !!" & vbCrLf & vbCrLf & "OK" & vbCrLf & vbTab & "TAB"
but not on selected text.

My macro:

Sub test()
strSample = " This is a sample string !!" & vbCrLf & vbCrLf & "OK" & vbCrLf & vbTab & "TAB"
'strSample = Selection.Text

Application.ScreenUpdating = False


Do While InStr(1, strSample, " ")
strSample = Replace(strSample, " ", " ")
Loop

Do While InStr(1, strSample, vbCrLf & vbCrLf)
strSample = Replace(strSample, vbCrLf & vbCrLf, "")
Loop

Do While InStr(1, strSample, vbTab)
strSample = Replace(strSample, vbTab, "")
Loop



'strSample = Trim(strSample)
Application.ScreenUpdating = True
MsgBox strSample
End Sub

[gmayor]

How about

Option Explicit
Sub TransposeName()
Dim orng As Range, oSel As Range
Dim oPara As Paragraph
Dim sText As String
Set oSel = Selection.Range
If Len(oSel) = 0 Then GoTo lbl_Exit
For Each oPara In oSel.Paragraphs
Set orng = oPara.Range
orng.End = orng.End - 1
orng.MoveEndWhile Chr(32), wdBackward
orng.Start = orng.Words.Last.Start
sText = orng.Text & Chr(44) & Chr(32)
orng.MoveEndUntil Chr(13)
orng.Text = ""
oPara.Range.InsertBefore sText
Next oPara
lbl_Exit:
Exit Sub
End Sub

[menteith]

Dear Graham,

Thank you very much for this. It (of course) does the trick.


Would it be to much if I kindly ask you to implement the cleaning of each line so that any not needed characters (double spaces, tabs, double new line characters, etc.) would be deleted? It will help me a lot when correcting my bibliography. I have also noticed that your code adds a space after the last character:

Smith, John[space]
I had tried to deal with this even before I started this thread but with no luck.
Thank you again for your help!

[gmayor]

It doesn't add a space. It leaves the space that was already present in your sample
Add the line
oSel.Text = Replace(oSel.Text, Chr(32) & Chr(13), Chr(13))immediately before
lbl_Exit:to remove it.
There are no double spaces, tabs etc in your sample?

[menteith]

It doesn't add a space.


Sorry, my bad. You are right.


The code now is:




Option Explicit
Sub TransposeName()
Dim orng As Range, oSel As Range
Dim oPara As Paragraph
Dim sText As String
Set oSel = Selection.Range
If Len(oSel) = 0 Then GoTo lbl_Exit
For Each oPara In oSel.Paragraphs
Set orng = oPara.Range
orng.End = orng.End - 1
orng.MoveEndWhile Chr(32), wdBackward
orng.Start = orng.Words.Last.Start
sText = orng.Text & Chr(44) & Chr(32)
orng.MoveEndUntil Chr(13)
orng.Text = ""
oPara.Range.InsertBefore sText
Next oPara
oSel.Text = Replace(oSel.Text, Chr(32) & Chr(13), Chr(13))
lbl_Exit:
Exit Sub
End Sub


It works great but it seems to not remove double spaces.



There are no double spaces, tabs etc in your sample?


In 'clean' sample (no double spaces, tabs etc) your macro works great. If add add intentionally some redundant characters (double spaces, double new lines, tabs) it still works but the result is different. Please have a look at a sample with some redundant characters:


John Smith



John Anderson Smith

John A. Smith
J.A. Smith


Your code [ with oSel.Text = Replace(oSel.Text, Chr(32) & Chr(13), Chr(13)) ] produces the following:


Smith, John
,
,
,
Smith, John Anderson
,
Smith, John A.
Smith, J.A.



The sample is available at: rghost.net/8wzk2mmkk

[gmayor]

See http://gregmaxey.mvps.org/word_tip_pages/cleanup_text.html which will help you cleanup your text.

[menteith]

I have been able to clean my selection. But but it seems that your macro really adds a space. Could you check it, please? At rghost.net/8SqG6lhsk you can find a Word document with no spaces after last character in each line.

[gmaxey]

I can confirm that Graham's macro is not adding any spaces. However, try this:


Sub TransposeNames()
Dim oRngProcess, oRng As Range
Dim oPara As Paragraph
If Selection.Type = wdSelectionNormal Then
Set oRngProcess = Selection.Range
For Each oPara In oRngProcess.Paragraphs
Set oRng = oPara.Range
With oRng
.End = .End - 1
.Words(1).InsertBefore .Words.Last & ", "
.Words.Last.Cut
.Text = Trim(.Text)
End With
Next oPara
End If
lbl_Exit:
Exit Sub
End Sub

[menteith]

Dear Greg,

Thank you for your time. Could you tell me what is the difference between your macro and Graham's? One sentence explanation would suffice. I'm just curious.


I can confirm that Graham's macro is not adding any spaces.

You are right. Graham's macro takes an unnecessary space from a text e.g.


John[space][space]Smith

and puts it at the end of the line:


Smith, John[space]

To cut a long story short, Graham's macro does what it should.

I have written my own code using regex to clean up selected text and when it is run both macros does what they should – no double spaces, tabs, empty lines etc. I'm really obligated! Would be so so kind to tell me how to deal with names starting with with e.g. 'van' etc? They are called participles.

What I would like to achieve is:


John van Smith -> van Smith, John

I thought of creating a list of such participles (most common are: van der, de, Van) that the macro would look for and put before surname, as in the above-mentioned example. Participles should be treated as case sensitive, so that 'van' would not be 'Van'.

[gmaxey]

It would be hard to explain the difference in one sentence. It is just a different take on manipulating a range:


Sub TransposeNames()
Dim oRngProcess, oRng As Range
Dim oPara As Paragraph
Dim arrParts() As String
Dim lngIndex As Long
arrParts = Split("de,der,van,Van", ",")
If Selection.Type = wdSelectionNormal Then
Set oRngProcess = Selection.Range
For Each oPara In oRngProcess.Paragraphs
Set oRng = oPara.Range
With oRng
.End = .End - 1
For lngIndex = 0 To UBound(arrParts)
If Trim(.Words(.Words.Count - 1)) = arrParts(lngIndex) Then
.Words(1).InsertBefore .Words(.Words.Count - 1) & .Words.Last & ", "
.Words.Last.Cut
.Words.Last.Cut
Exit For
End If
If lngIndex = UBound(arrParts) Then
.Words(1).InsertBefore .Words.Last & ", "
.Words.Last.Cut
End If
Next lngIndex
.Text = Trim(.Text)
End With
Next oPara
End If
lbl_Exit:
Exit Sub
End Sub

[menteith]

Greg

That's fantastic! I can supplement the list with, say, vander and it still does the trick. However, a two-word long participle as "van der" doesn't seem to work.
Are participles (de, van etc.) supposed to be in alphabetical order?

[gmaxey]

No it doesn't matter what order the parts are listed.


Sub TransposeNames()
Dim oRngProcess, oRng As Range
Dim oPara As Paragraph
Dim arrParts() As String, arrMultiPart() As String
Dim lngIndex As Long
arrParts = Split("van der,de,der,van,Van", ",")
If Selection.Type = wdSelectionNormal Then
Set oRngProcess = Selection.Range
For Each oPara In oRngProcess.Paragraphs
Set oRng = oPara.Range
With oRng
.End = .End - 1
For lngIndex = 0 To UBound(arrParts)
arrMultiPart = Split(arrParts(lngIndex), " ")
If UBound(arrMultiPart) = 1 Then
On Error GoTo Err_NextPart
If Trim(.Words(.Words.Count - 2) & .Words(.Words.Count - 1)) = arrParts(lngIndex) Then
.Words(1).InsertBefore .Words(.Words.Count - 2) & .Words(.Words.Count - 1) & .Words.Last & ", "
.Words.Last.Cut
.Words.Last.Cut
.Words.Last.Cut
Exit For
End If
If lngIndex = UBound(arrParts) Then
.Words(1).InsertBefore .Words.Last & ", "
.Words.Last.Cut
End If
Else
If Trim(.Words(.Words.Count - 1)) = arrParts(lngIndex) Then
.Words(1).InsertBefore .Words(.Words.Count - 1) & .Words.Last & ", "
.Words.Last.Cut
.Words.Last.Cut
Exit For
End If
If lngIndex = UBound(arrParts) Then
.Words(1).InsertBefore .Words.Last & ", "
.Words.Last.Cut
End If
End If
Err_NextPart:
Next lngIndex
.Text = Trim(.Text)
End With
Next oPara
End If
lbl_Exit:
Exit Sub
End Sub

[menteith]

Greg,
It works like a charm! You have made my day!

[gmaxey]

Just for s&g's lets take this one step further and process something like:


Jim E. Deer, Jr.

Joe L. Smith Sr

Bob van der Sloot IV

Tim R. de Bruin




Sub TransposeNames()
Dim oRngProcess, oRng As Range
Dim oPara As Paragraph
Dim arrParts() As String, arrMultiPart() As String
Dim lngIndex As Long
Dim strTemp As String
arrParts = Split("van der,de,der,van,Van", ",")
If Selection.Type = wdSelectionNormal Then
Set oRngProcess = Selection.Range
For Each oPara In oRngProcess.Paragraphs
strTemp = vbNullString
Set oRng = oPara.Range
With oRng
.End = .End - 1
Select Case oRng.Words.Last
Case "."
Select Case oRng.Words(oRng.Words.Count - 1)
Case "Jr", "Sr"
strTemp = Trim(oRng.Words(oRng.Words.Count - 1) & oRng.Words.Last)
oRng.Words.Last.Delete
oRng.Words.Last.Delete
End Select
Case "Jr", "Sr", "II", "III", "IV"
strTemp = Trim(oRng.Words.Last)
oRng.Words.Last.Delete
End Select
If oRng.Characters.Last.Previous = "," Then oRng.Characters.Last.Previous.Delete
For lngIndex = 0 To UBound(arrParts)
arrMultiPart = Split(arrParts(lngIndex), " ")
If UBound(arrMultiPart) = 1 Then
On Error GoTo Err_NextPart
If Trim(.Words(.Words.Count - 2) & .Words(.Words.Count - 1)) = arrParts(lngIndex) Then
.Words(1).InsertBefore Trim(.Words(.Words.Count - 2) & .Words(.Words.Count - 1) & .Words.Last) & ", "
.Words.Last.Cut
.Words.Last.Cut
.Words.Last.Cut
Exit For
End If
If lngIndex = UBound(arrParts) Then
.Words(1).InsertBefore .Words.Last & ", "
.Words.Last.Cut
End If
Else
If Trim(.Words(.Words.Count - 1)) = arrParts(lngIndex) Then
.Words(1).InsertBefore Trim(.Words(.Words.Count - 1) & .Words.Last) & ", "
.Words.Last.Cut
.Words.Last.Cut
Exit For
End If
If lngIndex = UBound(arrParts) Then
.Words(1).InsertBefore Trim(.Words.Last) & ", "
.Words.Last.Cut
End If
End If
Err_NextPart:
Next lngIndex
.Text = Trim(.Text)
If strTemp <> vbNullString Then
.Text = .Text & ", " & strTemp
End If
End With
Next oPara
End If
lbl_Exit:
Exit Sub
End Sub



P.S. I didn't suspect there would be so many de, van, van de (s) in Poland ;-)

[menteith]

P.S. I didn't suspect there would be so many de, van, van de (s) in Poland ;-)


You have given me a good laugh;) In fact, in Poland there are no surnames starting with van etc. but I often deal with papers written by the Dutch and the German. Btw, there is an American scholar whose full name reads: Bruce Bueno de Mesquita, and in bibliography should be entered as Bueno de Mesquita, Bruce. That's a lot complicated than the Dutch, Belgian and German cases altogether:)


Just for s&g's lets take this one step further and process something like:


Jim E. Deer, Jr.

Joe L. Smith Sr

Bob van der Sloot IV

Tim R. de Bruin

Great! The macro gives now:

Deer, Jim E., Jr.
Smith, Joe L., Sr
van der Sloot, Bob, IV
de Bruin, Tim R.

which is the correct format used by many reference managers, and this is the format in which names should be entered to work correctly in EndNote, a reference manager I use. For example, here (www2.hawaii.edu/~ltabata/endnote/enterinfo.html) there is a passage that explains this:

Note: For complex author names (Jr., II, multiple-words) always enter last name first, followed by titles:
de Gaulle, Charles
Smith, Alfred, Jr.

It seems you have been aware of this fact:)

[menteith]

Greg

I was so amazed by your work that I only recently checked your latest code on usual:


John Smith
John Anderson Smith
John A. Smith
J.A. Smith

and it does work correctly. But consider:


John Smith
Mary Jane
Lee Ang

and the macro stops at:


If Trim(.Words(.Words.Count - 2) & .Words(.Words.Count - 1)) = arrParts(lngIndex) Then

and the result is:


Smith, John
Mary Jane
Lee Ang

The macro also stops at:


If Trim(.Words(.Words.Count - 2) & .Words(.Words.Count - 1)) = arrParts(lngIndex) Then

when I have:


Jim E. Deer, Jr.
Joe L. Smith Sr
Bob van der Sloot IV
Tim R. de Bruin
John Smith
Mary Jane
Lee Ang


The result is:


Deer, Jim E., Jr.
Smith, Joe L., Sr
van der Sloot, Bob, IV
de Bruin, Tim R.
Smith, John
Mary Jane
Lee Ang

Each time the error reads:

Run-time error 5941:
The requested member of the collection does not exist.

I tested your code on Word 2010 and 2013 to make sure I didn't make any mistake.

[gmaxey]

Well that was sloppy of me ;-). GoTo doesn't clear the error handler:


Option Explicit
Sub TransposeNames()
Dim oRngProcess, oRng As Range
Dim oPara As Paragraph
Dim arrParts() As String, arrMultiPart() As String
Dim lngIndex As Long
Dim strTemp As String
arrParts = Split("van der,de,der,van,Van", ",")
If Selection.Type = wdSelectionNormal Then
Set oRngProcess = Selection.Range
For Each oPara In oRngProcess.Paragraphs
strTemp = vbNullString
Set oRng = oPara.Range
With oRng
.End = .End - 1
oRng.Text = Trim(oRng.Text)
Select Case oRng.Words.Last
Case "."
Select Case oRng.Words(oRng.Words.Count - 1)
Case "Jr", "Sr"
strTemp = Trim(oRng.Words(oRng.Words.Count - 1) & oRng.Words.Last)
oRng.Words.Last.Delete
oRng.Words.Last.Delete
End Select
Case "Jr", "Sr", "II", "III", "IV"
strTemp = Trim(oRng.Words.Last)
oRng.Words.Last.Delete
End Select
If oRng.Characters.Last.Previous = "," Then oRng.Characters.Last.Previous.Delete
For lngIndex = 0 To UBound(arrParts)
arrMultiPart = Split(arrParts(lngIndex), " ")
If UBound(arrMultiPart) = 1 Then
On Error GoTo Err_Part
If Trim(.Words(.Words.Count - 2) & .Words(.Words.Count - 1)) = arrParts(lngIndex) Then
.Words(1).InsertBefore Trim(.Words(.Words.Count - 2) & .Words(.Words.Count - 1) & .Words.Last) & ", "
.Words.Last.Cut
.Words.Last.Cut
.Words.Last.Cut
Exit For
End If
If lngIndex = UBound(arrParts) Then
.Words(1).InsertBefore .Words.Last & ", "
.Words.Last.Cut
End If
Else
If Trim(.Words(.Words.Count - 1)) = arrParts(lngIndex) Then
.Words(1).InsertBefore Trim(.Words(.Words.Count - 1) & .Words.Last) & ", "
.Words.Last.Cut
.Words.Last.Cut
Exit For
End If
If lngIndex = UBound(arrParts) Then
.Words(1).InsertBefore Trim(.Words.Last) & ", "
.Words.Last.Cut
End If
End If
Err_NextPart:
Next lngIndex
.Text = Trim(.Text)
If strTemp <> vbNullString Then
.Text = .Text & ", " & strTemp
End If
End With
Next oPara
End If
lbl_Exit:
Exit Sub
Err_Part:
Resume Err_NextPart
End Sub

[menteith]

Greg,

Works like a charm! Many thanks for your generous help.

[menteith]

Dear Greg,

Sorry for bothering you but I was thinking if you could modify your code once again to deal with surnames that have a hyphen.

E.g.
Jan Erik-Lane should give Erik-Lane, Jan.

Your current code gives: Lane, Jan Erik-

Many thanks!

[gmaxey]

At some point you are going to have to accept that in a world of 6 plus billion persons someone will conjure up a name that will not be processed by this or any macro:


Sub TransposeNames()
Dim oRngProcess, oRng As Range
Dim oPara As Paragraph
Dim arrParts() As String, arrMultiPart() As String
Dim lngIndex As Long
Dim strTemp As String
Dim oRngHyphenated As Range
arrParts = Split("van der,de,der,van,Van", ",")
If Selection.Type = wdSelectionNormal Then
Set oRngProcess = Selection.Range
For Each oPara In oRngProcess.Paragraphs
strTemp = vbNullString
Set oRng = oPara.Range
With oRng
.End = .End - 1
oRng.Text = Trim(oRng.Text)
Select Case oRng.Words.Last
Case "."
Select Case oRng.Words(oRng.Words.Count - 1)
Case "Jr", "Sr"
strTemp = Trim(oRng.Words(oRng.Words.Count - 1) & oRng.Words.Last)
oRng.Words.Last.Delete
oRng.Words.Last.Delete
End Select
Case "Jr", "Sr", "II", "III", "IV"
strTemp = Trim(oRng.Words.Last)
oRng.Words.Last.Delete
End Select
If oRng.Characters.Last.Previous = "," Then oRng.Characters.Last.Previous.Delete
For lngIndex = 0 To UBound(arrParts)
arrMultiPart = Split(arrParts(lngIndex), " ")
If UBound(arrMultiPart) = 1 Then
On Error GoTo Err_Part
If Trim(.Words(.Words.Count - 2) & .Words(.Words.Count - 1)) = arrParts(lngIndex) Then
.Words(1).InsertBefore Trim(.Words(.Words.Count - 2) & .Words(.Words.Count - 1) & .Words.Last) & ", "
.Words.Last.Cut
.Words.Last.Cut
.Words.Last.Cut
Exit For
End If
If lngIndex = UBound(arrParts) Then
.Words(1).InsertBefore .Words.Last & ", "
.Words.Last.Cut
End If
Else
If Trim(.Words(.Words.Count - 1)) = arrParts(lngIndex) Then
.Words(1).InsertBefore Trim(.Words(.Words.Count - 1) & .Words.Last) & ", "
.Words.Last.Cut
.Words.Last.Cut
Exit For
End If
If lngIndex = UBound(arrParts) Then
If .Words.Last.Characters.First.Previous = "-" Then
Set oRngHyphenated = .Words.Last
Do
oRngHyphenated.MoveStart wdCharacter, -1
Loop Until oRngHyphenated.Characters.First.Previous = " " Or oRngHyphenated.Characters.First.Previous = Chr(160)
.Words(1).InsertBefore Trim(oRngHyphenated) & ", "
oRngHyphenated.Cut
Else
.Words(1).InsertBefore Trim(.Words.Last) & ", "
.Words.Last.Cut
End If
End If
End If
Err_NextPart:
Next lngIndex
.Text = Trim(.Text)
If strTemp <> vbNullString Then
.Text = .Text & ", " & strTemp
End If
End With
Next oPara
End If
lbl_Exit:
Exit Sub
Err_Part:
Resume Err_NextPart
End Sub

[menteith]

Thank you. I accept this fact, but I allowed myself to ask you for changing the code because a hyphen is a quite common part of a surname.

[gmaxey]

You're welcome.