Sort lines ignoring the 1st character when it's a red dot “ ● ”

[gloub]

To manage my todo-list on Word, I sometimes sort by alphabetical order a previously selected part of it (see below).

Unfortunately, since I often use a red dot at the beginning of the line to draw attention to certain tasks, it disturbs the sorting.
I would like to find a way to make the sorting process ignore the presence of a dot at the beginning of the line.

So far, all I could think of (because my VBA is very poor) is:
- cut "manually" each point, then paste it at the end of the line
(I say lines but they are actually paragraphs, separated by line breaks)
- select the text to be sorted and then sort it.
- cut "manually" each point, then paste it at the beginning of the line

But obviously this is a slow process when it involves dozens of lines.
So I'm looking for a way to do it with a macro, but it's beyond my capabilities in VBA, which are very limited.

Can someone please help me?

Thanks...and Happy New Year!


TODO-LIST BEFORE SORTING
MDP : task n°1
●EVC : task n°2
MDP : task n°4
APV : task n°6
●BAF : task n°2
EVC : task n°1
BAF : task n°1
●BEG : task n°3
APV : task n°1
BEG : task n°2

TODO-LIST AFTER SORTING
APV : task n°1
APV : task n°6
BAF : task n°1
●BAF : task n°2
BEG : task n°2
●BEG : task n°3
EVC : task n°1
●EVC : task n°2
MDP : task n°1
MDP : task n°4

Paragraphs have been sorted regardless to the presence of a red dot.

[gmayor]

The following should work. Select the list then run the macro


Sub SortSelectedList()
Dim oColl As Collection
Dim oRng As Range
Dim i As Integer
Dim strText As String
Set oRng = Selection.Range
oRng.Text = Replace(oRng.Text, Chr(11), Chr(13))
Set oColl = New Collection
For i = 1 To oRng.Paragraphs.Count
If InStr(1, oRng.Paragraphs(i).Range.Text, Chr(58)) > 0 Then
oColl.Add oRng.Paragraphs(i).Range.Text
End If
Next i
Set oColl = SortCollection(oColl)
For i = 1 To oColl.Count
strText = strText & CStr(oColl(i))
Next i
oRng.Text = strText
With oRng.Find
Do While .Execute(findText:=ChrW(9679))
oRng.Font.ColorIndex = wdRed
Loop
End With
lbl_Exit:
Set oRng = Nothing
Set oColl = Nothing
Exit Sub
End Sub


Private Function SortCollection(colInput As Collection) As Collection
Dim iCounter As Integer
Dim iCounter2 As Integer
Dim temp As Variant
Set SortCollection = New Collection
For iCounter = 1 To colInput.Count - 1
For iCounter2 = iCounter + 1 To colInput.Count
If Replace(colInput(iCounter), ChrW(9679), "") > _
Replace(colInput(iCounter2), ChrW(9679), "") Then
temp = colInput(iCounter2)
colInput.Remove iCounter2
colInput.Add temp, temp, iCounter
End If
Next iCounter2
Next iCounter
Set SortCollection = colInput
End Function

[gloub]

Hi!
Thank you so much for your quick answer.
Yes, your macro works.
But there's one problem : it suppresses all formatting (font name and color, highlighting, etc...) which is an important feature of my todo-list.
Is there a way to fix this ?

Thanks.

[gmayor]

We just love it when you move the goalposts :banghead:

The following will maintain the formatting.


Sub SortSelectedList()

Dim i As Long
Dim oTable As Table
Dim oCell As Range
Dim oRng As Range
Application.ScreenUpdating = False
Set oRng = Selection.Range
With oRng.Find
Do While .Execute(Chr(11))
If oRng.InRange(Selection.Range) Then
oRng.Text = Chr(13)
End If
oRng.Collapse 0
Loop
End With
Selection.ConvertToTable _
Separator:=wdSeparateByParagraphs, _
NumColumns:=1, _
NumRows:=10, AutoFitBehavior:=wdAutoFitFixed
Selection.InsertColumns
Set oTable = Selection.Tables(1)
For i = 1 To oTable.Rows.Count
If oTable.Rows(i).Cells(2).Range.Characters(1) = ChrW(9679) Then
oTable.Rows(i).Cells(2).Range.Characters(1).Cut
oTable.Rows(i).Cells(1).Range.Paste
End If
Next i
oTable.AutoFitBehavior wdAutoFitContent
oTable.Sort ExcludeHeader:=False, _
FieldNumber:="Column 2", _
SortFieldType:=wdSortFieldAlphanumeric, _
SortOrder:=wdSortOrderAscending
For i = 1 To oTable.Rows.Count
If oTable.Rows(i).Cells(1).Range.Characters(1) = ChrW(9679) Then
oTable.Rows(i).Cells(1).Range.Characters(1).Cut
Set oCell = oTable.Rows(i).Cells(2).Range
oCell.Collapse 1
oCell.Paste
End If
Next i
oTable.Columns(1).Delete
oTable.ConvertToText Separator:=wdSeparateByParagraphs
Application.ScreenUpdating = True
Application.ScreenRefresh
lbl_Exit:
Set oTable = Nothing
Set oCell = Nothing
Set oRng = Nothing
Exit Sub
End Sub

[gloub]

We just love it when you move the goalposts
I'm sorry – actually I didn't think this had to be mentionned.

Otherwise, your code work perfectly. You're a Jedi !

Thank you so much !!!!!!