[Hỏi]Sắp lại vị trí các câu trong word

[thuthuy2000]

Thứ tự các câu hỏi trong word đang bị đảo lung tung. Em muốn sắp lại vị trí này tăng dần theo Câu (1,2,3...)
Mong được trợ giúp.

 

[Yukino Ichikawa]

Sub tuhocvba()
    Call SapXeptheoCau(1)
End Sub
'Nguon: BTPRO
Private Sub SapXeptheoCau(ByRef Loai As Byte)
         Dim doctThis As Document
        Dim doctThat As Document
        Set doctThis = ActiveDocument
        Dim c, i As Integer
        Dim Title, msg As String
        Dim DS_10 As String
      
        Dim ID, findTxt As String
        On Error Resume Next
        Call RemoveMarks
        c = 0
        DS_10 = "START"
        
        
    
        Selection.HomeKey Unit:=wdStory
        Selection.Find.ClearFormatting
        Selection.Find.Replacement.ClearFormatting
       If Loai = 1 Then
        findTxt = "(C" & ChrW(226) & "u [0-9]{1,3}[:.])"
       Else
        findTxt = "(C" & ChrW(226) & "u [0-9]{1,3}[:.][^9^32]\[[1-4]\])"
       End If
        
      
        With Selection.Find
            .Text = findTxt
            .Forward = True
            .Wrap = wdFindContinue
            .MatchWildcards = True
        End With
        Do While Selection.Find.Execute = True
            'Selection.Select
            
            ID = Trim(Selection)
            Selection.HomeKey Unit:=wdLine
            c = c + 1
            With ActiveDocument.Bookmarks
            .Add Range:=Selection.Range, Name:="c" & c & "q"
            .DefaultSorting = wdSortByName
            .ShowHidden = True
            End With
            Selection.EndKey Unit:=wdLine
            If Loai = 1 Then
                DS_10 = DS_10 & "," & Trim(Mid(ID, 5, Len(ID) - 5))
            Else
                DS_10 = DS_10 & "," & Trim(Mid(ID, Len(ID) - 1, 1))
            End If
            
        Loop
        'MsgBox (DS_10)
        If c = 0 Then
            Application.Assistant.DoAlert "Th" & ChrW(244) & "ng b" & ChrW(225) & "o", _
            "Khg t・ th" & ChrW(7845) & "y c穹 h" & ChrW(7887) & "i ph・h" & ChrW(7907) & "p." _
            , 0, 4, 0, 0, 0
            Exit Sub
        End If
  
        Selection.EndKey Unit:=wdStory
        Selection.TypeParagraph
        With ActiveDocument.Bookmarks
            .Add Range:=Selection.Range, Name:="c" & c + 1 & "q"
            .DefaultSorting = wdSortByName
            .ShowHidden = True
        End With
        
        Dim myRange As Range
        For i = 1 To c
  
            Set myRange = ActiveDocument.Range( _
                Start:=ActiveDocument.Bookmarks("c" & i & "q").Range.Start, _
                End:=ActiveDocument.Bookmarks("c" & i + 1 & "q").Range.End)
            myRange.Select
            
            With ActiveDocument.Bookmarks
                .Add Range:=Selection.Range, Name:="Q" & i
                .DefaultSorting = wdSortByName
                .ShowHidden = True
            End With
        Next
        
        Dim tamTT() As String
        Dim tam_MARK() As String
        Dim i1, i2 As Integer
        Dim tg As String
        
            tam_MARK = Split(DS_10, ",")
 
            If UBound(tam_MARK) > 0 Then
                ReDim tamTT(c + 1)
                For i = 1 To c
                    tamTT(i) = i
                Next
                
                For i1 = 1 To UBound(tam_MARK) - 1
                    For i2 = i1 + 1 To UBound(tam_MARK)
                        If Val(tam_MARK(i1)) > Val(tam_MARK(i2)) Then
                            tg = tam_MARK(i1)
                            tam_MARK(i1) = tam_MARK(i2)
                            tam_MARK(i2) = tg
                            tg = tamTT(i1)
                            tamTT(i1) = tamTT(i2)
                            tamTT(i2) = tg
                        End If
                    Next i2
                Next i1
            End If
            'MsgBox (tam_MARK(1) & tam_MARK(2) & tam_MARK(3) & tam_MARK(4) & tam_MARK(5))
            'MsgBox (tamTT(1) & tamTT(2) & tamTT(3) & tamTT(4) & tamTT(5))
  
    'Set doctThat = Documents.add
    For i = 1 To c
    'MsgBox (tamTT(i))
        Selection.GoTo what:=wdGoToBookmark, Name:="Q" & tamTT(i)
        Selection.Copy
        Selection.EndKey (wdStory)
        Selection.Paste
        Selection.GoTo what:=wdGoToBookmark, Name:="Q" & tamTT(i)
        Selection.Delete
    Next
    Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^p^p"
        .Replacement.Text = "^p"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    Do While .Execute
        .Execute Replace:=wdReplaceAll
    Loop
    End With
      
    Selection.HomeKey Unit:=wdStory
    MsgBox "Done"
End Sub
Sub RemoveMarks()
    Dim bkm As Bookmark
    For Each bkm In ActiveDocument.Bookmarks
    bkm.Delete
    Next bkm
End Sub

Bạn cần đăng nhập để thấy hình ảnh