T
thuthuy2000
Guest
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.
Mong được trợ giúp.
VIP
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", _
"Khg 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