在
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
|
0 comments:
張貼留言