Tự động hóa quy trình thủ công với Macro (Microsoft Word)

http://www.vbaexpress.com/forum/showthread.php?31231

Sub FootnotesEndnotes()

Dim fNote As Footnote     Dim eNote As Endnote     Dim aRange As Range     Dim sText As String     Dim rText As String     Dim eRef As String     Dim newDoc As Document     Dim oldDoc As Document

Set oldDoc = ActiveDocument     Set newDoc = Documents.Add

sText = "---------------FOOTNOTES---------------" & vbCr     newDoc.Content.InsertAfter sText

oldDoc.Activate     For Each fNote In ActiveDocument.Footnotes         Set aRange = fNote.Reference         aRange.MoveStart unit:=wdSentence, Count:=-1         aRange.MoveEnd unit:=wdSentence         sText = aRange.Text         rText = fNote.Range.Text         With fNote.Reference.Characters.First             .Collapse             .InsertCrossReference wdRefTypeFootnote, _               wdFootnoteNumberFormatted, fNote.Index             eRef = .Characters.First.Fields(1).Result             Selection.Start = fNote.Reference.Start - Len(eRef)

Selection.End = fNote.Reference.Start             Selection.Delete         End With         Call WriteNewdoc(newDoc, sText, rText, eRef, "Footnote Text")

Next fNote

sText = "---------------ENDNOTES----------------" & vbCr     newDoc.Content.InsertAfter vbCr & vbCr & sText

For Each eNote In ActiveDocument.Endnotes         Set aRange = eNote.Reference         aRange.MoveStart unit:=wdSentence, Count:=-1         aRange.MoveEnd unit:=wdSentence         sText = aRange.Text         rText = eNote.Range.Text         With eNote.Reference.Characters.First             .Collapse             .InsertCrossReference wdRefTypeEndnote, _               wdEndnoteNumberFormatted, eNote.Index             eRef = .Characters.First.Fields(1).Result             Selection.Start = eNote.Reference.Start - Len(eRef)

Selection.End = eNote.Reference.Start             Selection.Delete         End With         Call WriteNewdoc(newDoc, sText, rText, eRef, "Endnote Text")

Next eNote

newDoc.Activate End Sub

Sub WriteNewdoc(newDoc As Document, sText As String, rText As String, _        eRef As String, aStyle As String)

Dim sText1 As String     Dim sText2 As String     Dim dRange As Range     Dim k As Long     Dim curDoc As Document

Set curDoc = ActiveDocument     newDoc.Activate     k = InStr(sText, Chr(2))

If k = 1 Then sText = Mid(sText, 2) 'in case previous sentence has note     sText = Trim(sText)

k = InStr(sText, Chr(2))

If k = 0 Then         sText = sText & Chr(2)

k = Len(sText)

End If     If k > 1 Then         sText1 = Left(sText, k - 1)

Else         sText1 = ""

End If     If k = Len(sText) Then         sText2 = ""

Else         sText2 = Mid(sText, k + 1)

End If     If Len(sText2) > 0 Then         If Mid(sText2, Len(sText2), 1) = Chr(13) Then             sText2 = Left(sText2, Len(sText2) - 1)

End If     End If     Set dRange = newDoc.Content     dRange.Collapse Direction:=wdCollapseEnd     dRange.Select     With Selection         .InsertAfter vbCr & sText1         .Font.Superscript = False         .Collapse Direction:=wdCollapseEnd         .InsertAfter eRef         .Font.Superscript = True         .Collapse Direction:=wdCollapseEnd         .InsertAfter " " & sText2 & vbCr         .Font.Superscript = False         .Collapse Direction:=wdCollapseEnd         .InsertAfter eRef         .Font.Superscript = True         .Collapse Direction:=wdCollapseEnd         .InsertAfter " " & rText & vbCr & vbCr         .Font.Superscript = False         .Style = aStyle     End With     curDoc.Activate End Sub

http://www.archivepub.co.uk/book.html