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

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

Post Views: 935

在 VBA / Excel 使用VBA在Word檔內進行尋找取代的方法 說明了幾種處理方式

但是如果要成為工作流程，必須要增加一些功能與介面以方便使用

所以增加清除內容、 選取檔案、執行搜尋替代等功能

而目標字串(原字串)與替換字串(新字串)由於不同檔案可能有不同的需求，所以直接輸入在工作表

操作介面

1.刪除設定內容

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
 
Sub delRange()
    Dim r1 As Integer
    Dim r2 As Integer
    Dim Message1, Message2, Title As String
    
    Message1 = "請輸入起始列數"
    Message2 = "請輸入結束列數"
    Title = "設定刪除範圍"
    
    r1 = InputBox(Message1, Title)
    r2 = InputBox(Message2, Title)
    
    If r1 <> 1 And r1 <> 0 And r2 <> 1 And r2 <> 0 Then
        Sheets(1).Range("A" & r1 & ":" & "C" & r2).Clear
    Else
        MsgBox "請確認範圍"
    End If
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
 
Sub cmdSelectFile()
    Dim fd As FileDialog    '宣告一個檔案對話框
    Set fd = Application.FileDialog(msoFileDialogFilePicker)  '設定選取檔案功能
    
    fd.Filters.Clear    '清除之前的資料
    
    fd.InitialFileName = ActiveWorkbook.Path & Application.PathSeparator '設定初始目錄
    
    fd.Filters.Add "Word File", "*.doc*" '設定顯示的副檔名
    fd.Filters.Add "所有檔案", "*.*"
        
    fd.Show '顯示對話框
    
    Dim startx As Integer
    startx = Sheets(1).Range("A1000").End(xlUp).Row    '工作表已選取檔案數
'    MsgBox startx
    
    Dim i As Integer
    For i = 1 To fd.SelectedItems.Count
        Dim strFullName As String
        strFullName = fd.SelectedItems(i)
        
        '在A欄寫入檔案路徑與名稱
        Sheets(1).Cells(i + startx, 1) = strFullName
    Next i
    
End Sub

 

3.執行搜尋替代

將工作表的資料傳遞到#21  reText，執行搜尋與取代的流程

 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
 
Sub mainFn6()
    
    Dim r As Integer
    r = Sheets(1).Range("A1000").End(xlUp).Row
    
    Dim i As Integer
    
    For i = 2 To r
        DoEvents
        Dim fPath As String
        Dim oText As String
        Dim nText As String
        
        fPath = Sheets(1).Range("A" & i).Value
        oText = Sheets(1).Range("B" & i).Value
        nText = Sheets(1).Range("C" & i).Value
        
        '如果 A欄 B欄 C欄 都有資料才進行轉換
        If Not (fPath = "" Or oText = "" Or nText = "") Then
        
            Call reText(fPath, oText, nText)
        
        End If
    
    Next i
    
    MsgBox "完成"

End Sub

 

#21自訂程序 reText的程式碼

 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
 
' 晚期繫結 不能用名稱型態的常數
'
Sub reText(f As String, oT As String, nT As String)

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

    ' 打開Word文檔
    Dim WordDoc As Object
    Dim fPath As String
    fPath = f
    
    Set WordDoc = WordApp.Documents.Open(Filename:=fPath)
    
    'WordApp.Visible = True
    'WordApp.Activate

     ' 設置要查找和替換的文本
    Dim FindText As String
    Dim ReplaceText As String
    
    FindText = oT
    ReplaceText = nT
    
    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

 

其中的程序SearchAndReplaceInStory

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
 
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: ,