Copy and sort target text by first Character after the space in the text string

[tazmtiger]

Hi Everyone,

I use the following code to copy and and sort information from one sheet to another.

The code is basically used to copy & sort names from specific sheets via command buttons. (It works great and it does the job) but I was asked to make it sort by last name, not the first name.

The cells that the code copies from are written like this: (All text contained within the same cell for each name... Names are written as follow

Example format text: (With names and last names written in the same cell)

John Smith
Jane Doe
Jack Frost
Jane Smith
Jill Tracy
Donald Duck
Napoleon Dynamite

The code currently copies and sorts the names based on the first latter of the cell's string...

... I am hoping there is a way to tell it to copy and sort by the first character "after the space, or first character from the second part of the text string".

Can any someone Please! Assist me with this?

Here is my current code:

Sub CommandButton1_Click()

'Operators - A Shift
Worksheets("Drill Call List").Unprotect Password:="drill"
Range("B15:B200").Value = ""

Worksheets("Drill Call List").Protect Password:="drill"
Dim rng As Range, item As Range
Dim v() As Variant
Dim i As Integer
Dim lastrow As Long
Dim x As Long


Set rng = Sheets("Operators").Range("I9:I38")


i = 0
For Each item In rng
With item
If .Value > 0 Then
ReDim Preserve v(i)
v(i) = .Value
i = i + 1
End If
End With
Next


With Sheets("Drill Call List")
.Unprotect Password:="drill"
lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
If .Range("B16") = "" Then lastrow = 15
x = UBound(v) + 1
Worksheets("Operators").Range("I9:I38").Copy
Worksheets("Drill Call List").Range("B16").PasteSpecial -4163
.Range("B16").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=True, Transpose:=False
'Sort Copied Data
Range("B15:B54").Copy
ActiveSheet.Range("B16").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Selection.Sort key1:=Range("B16")

.Protect Password:="drill"
End With

End Sub

Any help with this would be greatly appreciated.

Thank you in advance.

 

[ParamRay]

Rather than calling the Sort method on the range, you can pass it as an argument to the following SortByLastName() procedure:

Public Sub SortByLastName(ByVal rngFullNames As Excel.Range)
  Dim astrFullNames() As String
  Dim astrSortedNames() As String
  Dim j As Long
  
  ReDim astrFullNames(1 To rngFullNames.Count)
  For j = 1 To rngFullNames.Count
    astrFullNames(j) = rngFullNames.Item(j).Value
  Next
  
  astrSortedNames = BubbleSort(astrFullNames)
  For j = 1 To rngFullNames.Count
    rngFullNames.Item(j).Value = astrSortedNames(j)
  Next
End Sub

The procedure above calls the two functions below:

Public Function BubbleSort(astrFullNames() As String) As String()
  Dim astrSortedNames() As String
  Dim blnSorted As Boolean
  Dim strTemp As String
  Dim j As Long
  
  astrSortedNames = astrFullNames()
  
  Do
    blnSorted = True
    For j = LBound(astrSortedNames) To UBound(astrSortedNames) - 1
      If StrComp(GetLastName(astrSortedNames(j)), _
                 GetLastName(astrSortedNames(j + 1)), _
                 vbTextCompare) > 0 Then
        blnSorted = False
        strTemp = astrSortedNames(j)
        astrSortedNames(j) = astrSortedNames(j + 1)
        astrSortedNames(j + 1) = strTemp
      End If
    Next
  Loop Until blnSorted
  
  BubbleSort = astrSortedNames()
End Function

Public Function GetLastName(ByVal strFullName As String) As String
  GetLastName = Right(strFullName, Len(strFullName) - InStr(1, strFullName, " "))
End Function

 

[tazmtiger]

Rather than calling the Sort method on the range, you can pass it as an argument to the following SortByLastName() procedure:

Public Sub SortByLastName(ByVal rngFullNames As Excel.Range)
  Dim astrFullNames() As String
  Dim astrSortedNames() As String
  Dim j As Long
  
  ReDim astrFullNames(1 To rngFullNames.Count)
  For j = 1 To rngFullNames.Count
    astrFullNames(j) = rngFullNames.Item(j).Value
  Next
  
  astrSortedNames = BubbleSort(astrFullNames)
  For j = 1 To rngFullNames.Count
    rngFullNames.Item(j).Value = astrSortedNames(j)
  Next
End Sub

The procedure above calls the two functions below:

Public Function BubbleSort(astrFullNames() As String) As String()
  Dim astrSortedNames() As String
  Dim blnSorted As Boolean
  Dim strTemp As String
  Dim j As Long
  
  astrSortedNames = astrFullNames()
  
  Do
    blnSorted = True
    For j = LBound(astrSortedNames) To UBound(astrSortedNames) - 1
      If StrComp(GetLastName(astrSortedNames(j)), _
                 GetLastName(astrSortedNames(j + 1)), _
                 vbTextCompare) > 0 Then
        blnSorted = False
        strTemp = astrSortedNames(j)
        astrSortedNames(j) = astrSortedNames(j + 1)
        astrSortedNames(j + 1) = strTemp
      End If
    Next
  Loop Until blnSorted
  
  BubbleSort = astrSortedNames()
End Function

Public Function GetLastName(ByVal strFullName As String) As String
  GetLastName = Right(strFullName, Len(strFullName) - InStr(1, strFullName, " "))
End Function

gpeacock ,

Thank you so much for all your time and effort given to my request, unfortunately, it did not work for me, I could not make it work in my case.

I really appreciate your valuable time given to try to assist me with my code request. Thank you very much!


However,
I did work in my code, and I got it to do what I need it to do, IT IS NOT PERFECT... But it works for now.

This is what I did to my code to make it work for me:

Part of Old Code (not modified)
Sub CommandButton1_Click()

'Operators - A Shift
Worksheets("Drill Call List").Unprotect Password:="drill"
Range("B15:B200").Value = ""

Worksheets("Drill Call List").Protect Password:="drill"
Dim rng As Range, item As Range
Dim v() As Variant
Dim i As Integer
Dim lastrow As Long
Dim x As Long


Set rng = Sheets("Operators").Range("I9:I38")


i = 0
For Each item In rng
With item
If .Value > 0 Then
ReDim Preserve v(i)
v(i) = .Value
i = i + 1
End If
End With
Next


With Sheets("Drill Call List")
.Unprotect Password:="drill"
lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
If .Range("B16") = "" Then lastrow = 15
x = UBound(v) + 1
Worksheets("Operators").Range("I9:I38").Copy
Worksheets("Drill Call List").Range("B16").PasteSpecial -4163
.Range("B16").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=True, Transpose:=False



Part Of Code I modified: (Old code segment)

'Sort Copied Data
Range("B15:B54").Copy
ActiveSheet.Range("B16").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Selection.Sort key1:=Range("B16")

.Protect Password:="drill"
End With

End Sub

Replaced it with this: (New code segment)

'Sort Copied Data ("By Last name")

Dim sCell As String
Dim sLast As String
Dim sFirst As String
Dim rCell As Range

For Each rCell In Selection
sCell = rCell.Value
x = InStr(sCell, " ")
If x > 0 Then
sFirst = Left(sCell, x - 1)
sLast = Mid(sCell, x + 1)
rCell.Value = sLast & ", " & sFirst
End If
Next
Set rCell = Nothing
Range("B15:B54").Copy
ActiveSheet.Range("B16").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Selection.Sort Key1:=Range("B16")

.Protect Password:="drill"
End With

End Sub



Once again gpeacock , Thank you! Is because of people like you, that this place is the greatest. Have a nice day!

 

[Rick Rothstein]

I think this code should do what you want...

[table="width: 500"]
[tr]
	[td]Sub CommandButton1_Click()
  Dim LastRow As Long
  LastRow = Cells(Rows.Count, "A").End(xlUp).Row
  Columns("A").Insert
  Range("A1:A" & LastRow) = Evaluate(Replace("IF(B1:B#="""","""",MID(B1:B#&"" "" &B1:B#,FIND("" "",B1:B#)+1,LEN(B1:B#)))", "#", LastRow))
  Columns("A:B").Sort Range("A1"), xlAscending
  Columns("A").Delete
End Sub[/td]
[/tr]
[/table]