Thread: [Solved] Sorting Request Help Needed
View Single Post
 
Old 10-14-2015, 03:01 PM
macropod's Avatar
macropod macropod is offline Windows 7 64bit Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 22,359
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

The prefix numbers you've added makes any sorting difficult, because they will ordinarily end up being part of the sort key. Sorting would have been easier if adding the prefixes had been left till after the questions were sorted. That said, try:
Code:
Sub Demo()
Application.ScreenUpdating = False
Dim Rng As Range, i As Long
With ActiveDocument
  With .Range
    Set Rng = .Duplicate
    .InsertBefore vbCr
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = "(^13)[0-9]{1,}. (ACA-[0-9]{5})"
      .Replacement.Text = "\1\2"
      .Forward = True
      .Wrap = wdFindContinue
      .Format = False
      .MatchWildcards = True
      .Execute Replace:=wdReplaceAll
      .Text = "^13ACA-[0-9]{5}"
      .Replacement.Text = ""
      .Wrap = wdFindStop
      .Execute
    End With
    Do While .Find.Found
      .Start = .Start + 1
      Rng.Start = .End
      With Rng
        With .Find
          .Text = "^13ACA-[0-9]{5}"
          .Replacement.Text = ""
          .Forward = True
          .Wrap = wdFindStop
          .Format = False
          .MatchWildcards = True
          .Execute
        End With
        If .Find.Found Then
          Rng.Start = .Start
        Else
          Rng.Start = ActiveDocument.Range.End
        End If
      End With
      .End = Rng.Start
      .ConvertToTable NumColumns:=1, Format:=wdTableFormatNone, AutoFitBehavior:=wdAutoFitWindow
      .Duplicate.Cells.Merge
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
  While .Tables.Count > 1
    .Tables(1).Range.Characters.Last.Next.Delete
  Wend
  With .Tables(1)
    .Sort
    .ConvertToText
  End With
  With .Range
    With .Find
      .Text = "^13ACA-[0-9]{5}"
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindStop
      .Format = False
      .MatchWildcards = True
      .Execute
    End With
    Do While .Find.Found
      i = i + 1
      .Start = .Start + 1
      .InsertBefore vbCr & i & ". "
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
  .Range.Characters.First.Delete
  .Range.Characters.First.Delete
End With
Application.ScreenUpdating = True
End Sub
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote