Military Name Format code

T

tbird

Board Regular
Joined
Oct 21, 2002
Messages
184
Hi everyone! This post is informational in the spirit of giving back to the community from which I have received help. With a lot of coding help from experts on this board (Thanks to Jimboy, Andrew Poulsom, & Barrie Davidson), I have collected the necessary code to convert a column of names(first, middle, last) to U. S. Military format (Last, first, middle) and back again. The usefulness for me is to enable automatic sorting by last name. This code allows you to select the 1st cell in the list instead of the entire list before initiating the macro. There are two sets of code below. . I activate the code with two separate tool buttons to let me perform the sort operation in the middle and also clean up any glitches. Of necessity (for me), the code was recorded/copied into separate subroutines. Someone with more experience can probably condense this into fewer lines.
Note that this code inserts four columns to the right of the column of names and then deletes them leaving the other data in the spreadsheet intact. In addition, it also only works on contiguous cells in the column, so if there is a gap; it will not touch anything below the gap. In the pasted screenshots, the first is the original data, the second is the data with names in military format, and the third is the final with data sorted alphabetically by last name and the names converted back.

Military Name Conversion Code:

Code: 
'Dim c As Range
'Dim mylast
'Dim newlast
Public firstcell As Range


        
Sub FourColInsrt()
'
' FourColInsrt Macro
'
     ActiveCell.Offset(0, 1).Select
        Selection.EntireColumn.Insert
        Selection.EntireColumn.Insert
        Selection.EntireColumn.Insert
        Selection.EntireColumn.Insert
 '
     ActiveCell.Offset(0, -1).Select
     Set firstcell = Range(ActiveCell.Address)
     Call LNFormulaInsrt
End Sub


Sub LNFormulaInsrt()
'
' LNFormulaInsrt Macro
'
'    mylast = Cells.SpecialCells(xlLastCell).Row - ActiveCell.Row
'
    Do While ActiveCell.Value<> Empty
        ActiveCell.Offset(0, 1).Formula = "=RIGHT(RC[-1],LEN(RC[-1])-FIND(""*"",SUBSTITUTE(RC[-1],"" "",""*"",LEN(RC[-1])-LEN(SUBSTITUTE(RC[-1],"" "","""")))))"
        ActiveCell.Offset(1, 0).Select
    Loop
    
'    For Each c In Range(ActiveCell.Address, Range(ActiveCell.Offset(mylast, 0).Address))
'       If c.Value<> Empty Then
'            c.Offset(0, 1).Formula = "=RIGHT(RC[-1],LEN(RC[-1])-FIND(""*"",SUBSTITUTE(RC[-1],"" "",""*"",LEN(RC[-1])-LEN(SUBSTITUTE(RC[-1],"" "","""")))))"
'       End If
'    Next c
    firstcell.Select
    Call FNFormulaInsrt
End Sub
Sub FNFormulaInsrt()
'
' FNFormulaInsrt Macro
'
    Do While ActiveCell.Value<> Empty
        ActiveCell.Offset(0, 2).Formula = "=LEFT(RC[-2],FIND("" "",RC[-2])-1)"
        ActiveCell.Offset(1, 0).Select
    Loop
    
'    For Each c In Range(ActiveCell.Address, Range(ActiveCell.Offset(mylast, 0).Address))
'    If c.Value<> Empty Then
'        c.Offset(0, 2).Formula = "=LEFT(RC[-2],FIND("" "",RC[-2])-1)"
'    End If
'    Next c
    firstcell.Select
    Call MIFormulaInsrt
End Sub
Sub MIFormulaInsrt()
'
' Formula3Insrt Macro
'
    Do While ActiveCell.Value<> Empty
        ActiveCell.Offset(0, 3).Formula = "=IF(ISERR(MID(RC[-3],FIND("" "",RC[-3])+1,IF(ISERR(FIND("" "",RC[-3],FIND("" "",RC[-3])+1)),FIND("" "",RC[-3]),FIND("" "",RC[-3],FIND("" "",RC[-3])+1))-FIND("" "",RC[-3])-1)),"""",MID(RC[-3],FIND("" "",RC[-3])+ 1,IF(ISERR(FIND("" "",RC[-3],FIND("" "",RC[-3])+1)),FIND("" "",RC[-3]),FIND("" "",RC[-3],FIND("" "",RC[-3])+1))-FIND("" "",RC[-3])-1))"
        ActiveCell.Offset(1, 0).Select
    Loop


'    For Each c In Range(ActiveCell.Address, Range(ActiveCell.Offset(mylast, 0).Address))
'    If c.Value<> Empty Then
'        c.Offset(0, 3).Formula = "=IF(ISERR(MID(RC[-3],FIND("" "",RC[-3])+1,IF(ISERR(FIND("" "",RC[-3],FIND("" "",RC[-3])+1)),FIND("" "",RC[-3]),FIND("" "",RC[-3],FIND("" "",RC[-3])+1))-FIND("" "",RC[-3])-1)),"""",MID(RC[-3],FIND("" "",RC[-3])+ 1,IF(ISERR(FIND("" "",RC[-3],FIND("" "",RC[-3])+1)),FIND("" "",RC[-3]),FIND("" "",RC[-3],FIND("" "",RC[-3])+1))-FIND("" "",RC[-3])-1))"
'    End If
'    Next c
    firstcell.Select
    Call ConcatFormulaInsrt
End Sub
Sub ConcatFormulaInsrt()
'
' ConcatFormulaInsrt Macro
'
    Do While ActiveCell.Value<> Empty
        ActiveCell.Offset(0, 4).Formula = "=CONCATENATE(RC[-3],"","","" "",RC[-2],"" "",RC[-1])"
        ActiveCell.Offset(1, 0).Select
    Loop

'    For Each c In Range(ActiveCell.Address, Range(ActiveCell.Offset(mylast, 0).Address))
'    If c.Value<> Empty Then
'        c.Offset(0, 4).Formula = "=CONCATENATE(RC[-3],"","","" "",RC[-2],"" "",RC[-1])"
'    End If
'    Next c
    firstcell.Select
    Call ColClnup
End Sub

Sub ColClnup()

' ColClnup Macro
'
    Range(Cells(ActiveCell.Row, ActiveCell.Column + 4), Cells(65536, ActiveCell.Column + 4).End(xlUp)).Copy
        Selection.PasteSpecial paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
        ActiveCell.Offset(0, 1).Resize(1, 4).EntireColumn.Delete

End Sub

The following code reverses the process and restores the names in the original order.

Code: 
'Dim c As Range
'Dim mylast
'Dim newlast
Public firstcell As Range


Sub RMNFourColInsrt()
'
    ActiveCell.Offset(0, 1).Select
        Selection.EntireColumn.Insert
        Selection.EntireColumn.Insert
        Selection.EntireColumn.Insert
        Selection.EntireColumn.Insert
'
    ActiveCell.Offset(0, -1).Select
    Set firstcell = Range(ActiveCell.Address)

    Call RMNFNInsrt
End Sub


Sub RMNFNInsrt()
'
'  mylast = Cells.SpecialCells(xlLastCell).Row - ActiveCell.Row
'
    Do While ActiveCell.Value<> Empty
        ActiveCell.Offset(0, 1).Formula = "=IF(ISERR(MID(RC[-1],FIND("" "",RC[-1])+1,IF(ISERR(FIND("" "",RC[-1],FIND("" "",RC[-1])+1)), FIND("" "",RC[-1]),FIND("" "",RC[-1],FIND("" "",RC[-1])+1))-FIND("" "",RC[-1])-1)),"""",MID(RC[-1],FIND("" "",RC[-1])+ 1,IF(ISERR(FIND("" "",RC[-1],FIND("" "",RC[-1])+1)),FIND("" "",RC[-1]),FIND("" "",RC[-1],FIND("" "",RC[-1])+1))-FIND("" "",RC[-1])-1))"
        ActiveCell.Offset(1, 0).Select
    Loop
'    For Each c In Range(ActiveCell.Address, Range(ActiveCell.Offset(mylast, 0).Address))
'    If c.Value<> Empty Then
'        c.Offset(0, 1).Formula = "=IF(ISERR(MID(RC[-1],FIND("" "",RC[-1])+1,IF(ISERR(FIND("" "",RC[-1],FIND("" "",RC[-1])+1)), FIND("" "",RC[-1]),FIND("" "",RC[-1],FIND("" "",RC[-1])+1))-FIND("" "",RC[-1])-1)),"""",MID(RC[-1],FIND("" "",RC[-1])+ 1,IF(ISERR(FIND("" "",RC[-1],FIND("" "",RC[-1])+1)),FIND("" "",RC[-1]),FIND("" "",RC[-1],FIND("" "",RC[-1])+1))-FIND("" "",RC[-1])-1))"
'    End If
'    Next c
    firstcell.Select
    Call RMNLNInsrt
End Sub
Sub RMNLNInsrt()
'
    Do While ActiveCell.Value<> Empty
        ActiveCell.Offset(0, 2).Formula = "=LEFT(RC[-2],FIND("" "",RC[-2])-2)"
        ActiveCell.Offset(1, 0).Select
    Loop
'    For Each c In Range(ActiveCell.Address, Range(ActiveCell.Offset(mylast, 0).Address))
'    If c.Value<> Empty Then
'        c.Offset(0, 2).Formula = "=LEFT(RC[-2],FIND("" "",RC[-2])-2)"
'    End If
'    Next c
    firstcell.Select
    Call RMNMNInsrt
End Sub
Sub RMNMNInsrt()
'
        Do While ActiveCell.Value<> Empty
        ActiveCell.Offset(0, 3).Formula = "=RIGHT(RC[-3],LEN(RC[-3])-FIND(""*"",SUBSTITUTE(RC[-3],"" "",""*"",LEN(RC[-3])-LEN(SUBSTITUTE(RC[-3],"" "","""")))))"
        ActiveCell.Offset(1, 0).Select
    Loop

'   For Each c In Range(ActiveCell.Address, Range(ActiveCell.Offset(mylast, 0).Address))
'   If c.Value<> Empty Then
'       c.Offset(0, 3).Formula = "=RIGHT(RC[-3],LEN(RC[-3])-FIND(""*"",SUBSTITUTE(RC[-3],"" "",""*"",LEN(RC[-3])-LEN(SUBSTITUTE(RC[-3],"" "","""")))))"
'   End If
'   Next c
    firstcell.Select
    Call RMNConcatFormulaInsrt
End Sub

Sub RMNConcatFormulaInsrt()
'
' ConcatFormulaInsrt Macro
'
    Do While ActiveCell.Value<> Empty
        ActiveCell.Offset(0, 4).Formula = "=CONCATENATE(RC[-3],"" "",RC[-1],"" "",RC[-2])"
        ActiveCell.Offset(1, 0).Select
    Loop

'    For Each c In Range(ActiveCell.Address, Range(ActiveCell.Offset(mylast, 0).Address))
'    If c.Value<> Empty Then
'        c.Offset(0, 4).Formula = "=CONCATENATE(RC[-3],"" "",RC[-1],"" "",RC[-2])"
'    End If
'    Next c
    firstcell.Select
    Call ColClnup
End Sub
Sub ColClnup()

' ColClnup Macro
'
    Range(Cells(ActiveCell.Row, ActiveCell.Column + 4), Cells(65536, ActiveCell.Column + 4).End(xlUp)).Copy
        Selection.PasteSpecial paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
        ActiveCell.Offset(0, 1).Resize(1, 4).EntireColumn.Delete

End Sub
PERSONAL.XLS
ABCDE
1InitialNamesAddressesCityPhonenumbersZipcode
2TomSmyth1234statestDetroit555-121212345
3FredE.Brown1235statestDetroit555-121312346
4JohnSmith1236statestDetroit555-121412347
5M.A.Blond1237statestDetroit555-121512348
6A.Green1238statestDetroit555-121612349
Original
PERSONAL.XLS
ABCDE
1InitialNamesAddressesCityPhonenumbersZipcode
2Smyth,Tom1234statestDetroit555-121212345
3Brown,FredE.1235statestDetroit555-121312346
4Smith,John1236statestDetroit555-121412347
5Blond,M.A.1237statestDetroit555-121512348
6Green,A.1238statestDetroit555-121612349
Military Names
PERSONAL.XLS
ABCDE
1InitialNamesAddressesCityPhonenumbersZipcode
2TomSmyth1234statestDetroit555-121212345
3M.A.Blond1237statestDetroit555-121512348
4FredE.Brown1235statestDetroit555-121312346
5A.Green1238statestDetroit555-121612349
6JohnSmith1236statestDetroit555-121412347
Final Sorted
 

Excel Facts

Copy PDF to Excel
Select data in PDF. Paste to Microsoft Word. Copy from Word and paste to Excel.
You must log in or register to reply here.

Similar threads

L
  • Solved
VBA remove leading zeros
2
Replies
14
Views
952
Joe4
Joe4
J
  • Question
VBA Code to Add Rows is slowing down
Replies
5
Views
501
JayB0730
J
R
  • Question
Is There a More Efficient Way to Code This?
Replies
2
Views
347
offthelip
O
H
  • Solved
Macro to display message end of Code where Col D contains blanks
Replies
7
Views
336
howard
H
G
  • Question
How can i extract the correct leave time on this code?
Replies
1
Views
362
rlv01
R

Forum statistics

Threads
1,214,806
Messages
6,121,672
Members
449,045
Latest member
Marcus05

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top