VBA / Excel 使用VBA在Word檔內進行尋找取代的方法

VBA / Excel 使用VBA在Word檔內進行尋找取代的方法

Post Views: 908

這個是在Line社群的問題

發問者自己也在網路上爬文，但是對於一些問題無發解決才來提問

他的問題其實是VBA繫結的問題，他參考的範例是用早期繫結的方式引用word物件

但是在文章中沒有說明，導致這位發問者執行程式時出現錯誤訊息

也因為這個提問，讓我嘗試用VBA來進行word尋找取代的功能

Word VBA的物件架構對我而言還蠻複雜的，微軟自己的參考頁面也沒有很清楚的說明文件

(也或許是我自己沒找到)

例如這個 Word object model，是在VSTO的說明文件內

根據不同的教學文章，我自己總結了幾個方式

1.替換內容文字

這個是直接使用word物件的Content屬性

Content屬性會回傳一個Range 物件，然後可以使用Find屬性

Find屬性會再回傳一個Find物件

可以使用其中的Text、.Replacement.Text設定目標字串、替換字串

再用Execute方法執行整個尋找替換流程

例如以下的程式碼，必須要留意的是晚期繫結，不能使用名稱型態的常數

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
 
'
' 替換內容文字
'
' 晚期繫結 不能用名稱型態的常數
'
Sub ChangeWordDocumentText()

    ' 晚期繫結
    Dim WordApp As Object
    
    ' 創建Word應用程序
    Set WordApp = CreateObject("Word.Application")

    ' 打開Word文檔
    Dim WordDoc As Object
    Dim fPath As String
    fPath = ThisWorkbook.Path
    
    Set WordDoc = WordApp.Documents.Open(Filename:=fPath & "\替換範例檔.docx")
    
    'WordApp.Visible = True
    'WordApp.Activate

     ' 設置要查找和替換的文本
    Dim FindText As String
    Dim ReplaceText As String
    
    FindText = "SSS公司"
    ReplaceText = "DDD公司"

    ' 查找並替換文本
    With WordDoc.Content.Find
         .Text = FindText
         .Replacement.Text = ReplaceText
         .Execute Replace:=2     '早期繫結 wdReplaceAll
    End With

    ' 關閉並保存Word文檔
    WordDoc.Close SaveChanges:=True

    ' 關閉Word應用程序
    WordApp.Quit

    ' 釋放對象
    Set WordDoc = Nothing
    Set WordApp = Nothing

End Sub

2.替換頁首頁尾文字

這個牽涉到頁首、頁尾跟內容是分別的物件，所以前面的方法不會對頁首頁尾產生效果

頁首跟頁尾還有不同章節的區分，因此必須要一個一個章節的處理

例如以下程式碼

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
 
'
' 替換頁首頁尾文字
'
' 晚期繫結 不能用名稱型態的常數
'
Sub SearchAllHeadersAndFooters()

    ' 晚期繫結
    Dim WordApp As Object
    
    ' 創建Word應用程序
    Set WordApp = CreateObject("Word.Application")

    ' 打開Word文檔
    Dim WordDoc As Object
    Dim fPath As String
    fPath = ThisWorkbook.Path
    
    Set WordDoc = WordApp.Documents.Open(Filename:=fPath & "\替換範例檔.docx")
    
     ' 設置要查找和替換的文本
    Dim FindText As String
    Dim ReplaceText As String
    
    FindText = "SSS公司"
    ReplaceText = "DDD公司"
    
    Dim s As Object
    Dim hf As Object
    Dim rng As Object
    
    For Each s In WordDoc.Sections
        For Each hf In s.Headers
            Set rng = hf.Range
            rng.Select
            
            Dim xSelection As Object
            Set xSelection = WordDoc.Application.Selection
            With xSelection.Find
                .Text = FindText
                .Replacement.Text = ReplaceText
                .Wrap = 1 'wdFindContinue
                .Execute Replace:=2 'wdReplaceAll
            End With
        Next hf
        
        For Each hf In s.Footers
            Set rng = hf.Range
            
            rng.Select
            Set xSelection = WordDoc.Application.Selection
            With xSelection.Find
                .Text = FindText
                .Replacement.Text = ReplaceText
                .Wrap = 1 'wdFindContinue
                .Execute Replace:=2 'wdReplaceAll
            End With
        Next hf
    Next s
    
    ' 關閉並保存Word文檔
    WordDoc.Close SaveChanges:=True

    ' 關閉Word應用程序
    WordApp.Quit

    ' 釋放對象
    Set WordDoc = Nothing
    Set WordApp = Nothing
End Sub

 

程式碼的34-44是將整個章節選取起來，變成一個selection物件

但其實也可以直接用range物件

 

3.使用StoryRanges物件

前面兩個方法都是根據不同的物件分別使用對應的方法或屬性

但其實這些物件都又屬於StoryRanges物件內的不同StoryType

名稱 值 描述
wdCommentsStory 4 註解本文。
wdEndnoteContinuationNoticeStory 17 章節附註接續註明本文。
wdEndnoteContinuationSeparatorStory 16 章節附註接續分隔符號本文。
wdEndnoteSeparatorStory 15 章節附註分隔符號本文。
wdEndnotesStory 3 章節附註本文。
wdEvenPagesFooterStory 8 偶數頁頁尾本文。
wdEvenPagesHeaderStory 6 偶數頁頁首本文。
wdFirstPageFooterStory 11 第一頁頁尾本文。
wdFirstPageHeaderStory 10 第一頁頁首本文。
wdFootnoteContinuationNoticeStory 14 註腳接續註明本文。
wdFootnoteContinuationSeparatorStory 13 註腳接續分隔符號本文。
wdFootnoteSeparatorStory 12 註腳分隔符號本文。
wdFootnotesStory 2 註腳本文。
wdMainTextStory 1 主文字本文。
wdPrimaryFooterStory 9 主頁尾本文。
wdPrimaryHeaderStory 7 主頁首本文。
wdTextFrameStory 5 文字圖文框本文。

 

所以可以用判斷式來決定要處理哪些StoryType

使用StoryRanges物件的方法或屬性來處理尋找替換

例如以下的程式碼就包含了內容、頁首頁尾、以及其中的文字框(另外再用 ShapeRange來處理)

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
 
'
' 晚期繫結 不能用名稱型態的常數
'
Sub reText()

    ' 晚期繫結
    Dim WordApp As Object
    
    ' 創建Word應用程序
    Set WordApp = CreateObject("Word.Application")

    ' 打開Word文檔
    Dim WordDoc As Object
    Dim fPath As String
    fPath = ThisWorkbook.Path
    
    Set WordDoc = WordApp.Documents.Open(Filename:=fPath & "\替換範例檔.docx")
    
    'WordApp.Visible = True
    'WordApp.Activate

     ' 設置要查找和替換的文本
    Dim FindText As String
    Dim ReplaceText As String
    
    FindText = "SSS公司"
    ReplaceText = "DDD公司"
    
    Dim rngStory As Object
    For Each rngStory In WordDoc.StoryRanges
    
        'Iterate through all linked stories
    
        Do
    
          SearchAndReplaceInStory rngStory, oT, nT
    
          On Error Resume Next
    
          Select Case rngStory.StoryType
    
          Case 6, 7, 8, 9, 10, 11
    
            If rngStory.ShapeRange.Count > 0 Then
              
              Dim oShp As Object
              
              For Each oShp In rngStory.ShapeRange
                
                If oShp.TextFrame.HasText Then
    
                  SearchAndReplaceInStory oShp.TextFrame.TextRange, oT, nT
    
                End If
    
              Next
    
            End If
    
          Case Else
    
            'Do Nothing
    
          End Select
    
          On Error GoTo 0
    
          'Get next linked story (if any)
    
          Set rngStory = rngStory.NextStoryRange
    
        Loop Until rngStory Is Nothing
    
      Next


    ' 關閉並保存Word文檔
    WordDoc.Close SaveChanges:=True

    ' 關閉Word應用程序
    WordApp.Quit

    ' 釋放對象
    Set WordDoc = Nothing
    Set WordApp = Nothing

End Sub

 

程式碼的36行，將相關的參數傳遞到自訂程序-SearchAndReplaceInStory來處理尋找替換的流程

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
 
Public Sub SearchAndReplaceInStory(ByVal rngStory As Object, _
    ByVal strSearch As String, ByVal strReplace As String)


  With rngStory.Find

    .ClearFormatting

    .Replacement.ClearFormatting

    .Text = strSearch

    .Replacement.Text = strReplace

    .Wrap = 1 'wdFindContinue

    .Execute Replace:=2 'wdReplaceAll

  End With

End Sub

 

 

Tags: ,