Excel / 使用VBA控制word物件來分割表格

之前在「Word / 使用VBA分割word內的表格」使用VBA分割表格

現在同樣的原因需要分割審查結果的表格

表格架構都一樣，要輸出的內容架構也一樣

這次改在excel控制word物件來分割word裡的表格

操作介面的架構跟word一樣，樣式如下

 

在excel要控制word，就是把word當成一種物件來呼叫與操作

必須透過繫結來引入物件，繫結又分為早期與晚期

早期繫結必須先在工具/設定引用項目 勾選 目前的word物件庫

可以直接宣告物件類型，利用New來建立物件

Dim wordApp As Word.Application

Set WordApp = New Word.Application

晚期繫結則是先宣告Object物件， 再利用CreateObject 函式傳回的物件

Dim wordApp As Object

Set wordApp = CreateObject("Word.Application")

---

 

程式碼在結構上沒有太大的差異，主要就是修改物件的宣告

以及因為資料是取自excel工作表，所以抓取資料的方式也改為excel VBA的方式

不過程式碼的名稱要留意，在word VBA程式碼是綁定按鈕的click事件

所以在編輯器(VBE)會看到 按鈕名稱_click()的程序

如果直接搬到excel VBA的編輯器，也會被認定為是某個表單物件的click事件

所以要指定巨集時，不會顯示這些程序，必須刪除_click

選取檔案

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

Sub cmdSelectFile()
Dim fd As FileDialog '宣告一個檔案對話框

Set fd = Application.FileDialog(msoFileDialogFilePicker) '設定選取檔案功能


'FileName = Word.ActiveDocument.Name '參數檔案
'Debug.Print FileName

fd.Filters.Clear '清除之前的資料

'fd.Filters.Add "所有檔案", "*.*"

'設定顯示的副檔名
fd.Filters.Add "Word File", "*.doc, *.docx"

'設定檔案選取的預設路徑
fd.InitialFileName = ActiveWorkbook.Path & Application.PathSeparator

'允許多選
fd.AllowMultiSelect = True

fd.Show '顯示對話框

Dim startx As Integer
If Range("A1").End(xlDown).Row = 1048576 Then
startx = 0 '已選取檔案數
Else
startx = Range("A1").End(xlDown).Row - 1
End If
Dim i As Integer
Dim n As Integer
Dim strFullName As String


For i = 1 To fd.SelectedItems.Count
strFullName = fd.SelectedItems(i)

Sheets(1).Cells(i + 1 + startx, 1) = i + startx
Sheets(1).Cells(i + 1 + startx, 2) = strFullName

Next
End Sub

 

清除

1
2
3

Sub cmdClearSelectFile()
Sheets(1).Range("A2:C" & Excel.Rows.Count).Clear '將舊的A-C欄資料清除
End Sub

 

分割表格

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
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153

Sub cmdGO()

Application.ScreenUpdating = False

' 宣告物件
Dim WordApp As Word.Application
Dim WordDoc As Word.Document

' 創建一個新的Word應用程序對象
On Error Resume Next
Set WordApp = GetObject(, "Word.Application")
If WordApp Is Nothing Then
Set WordApp = New Word.Application ' 早期繫結
End If
On Error GoTo 0

' WordApp.Visible = True

Dim fPath As String
Dim i As Integer

If Range("A1").End(xlDown).Row = 1048576 Then
i = 2
Else
i = Range("A1").End(xlDown).Row
End If

For r = 2 To i
''
'取得word檔案路徑
fPath = Range("B" & r).Value

'新增檔案命名的依據
c = Range("C" & r).Value

'檢查檔案是否存在
If Dir(fPath) <> "" And c <> "" Then
'打開Word文檔
Set WordDoc = WordApp.Documents.Open(fileName:=fPath)

'取得邊界
tbMargin = WordApp.PointsToMillimeters(WordDoc.PageSetup.TopMargin)
lrMargin = WordApp.PointsToMillimeters(WordDoc.PageSetup.RightMargin)

'設定工作資料夾
'建立選擇目錄的對話方塊
Dim fDialog As FileDialog

Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)

fDialog.Filters.Clear

fDialog.InitialFileName = ActiveWorkbook.Path & Application.PathSeparator

If fDialog.Show Then
'顯示選擇的目錄
'MsgBox fDialog.SelectedItems(1)
WordApp.ChangeFileOpenDirectory fDialog.SelectedItems(1)
End If

Dim mytable As Object
Set mytable = WordDoc.Tables(1)

'Debug.Print mytable.Rows.Count

' for loop start
Dim p As Integer

For p = 2 To mytable.Rows.Count
WordDoc.Range(mytable.Rows(1).Range.Start, mytable.Rows(2).Range.End).Select

WordApp.Selection.Copy

'建立新檔案
Dim tp As Object
Set tp = WordApp.Documents.Add(Template:="Normal", NewTemplate:=False, DocumentType:=False)

'Debug.Print ActiveDocument.Name

tp.Activate

'橫式頁面
If tp.PageSetup.Orientation = wdOrientPortrait Then
tp.PageSetup.Orientation = wdOrientLandscape
Else
tp.PageSetup.Orientation = wdOrientPortrait
End If

'設定邊界
tp.PageSetup.TopMargin = WordApp.MillimetersToPoints(tbMargin)
tp.PageSetup.BottomMargin = WordApp.MillimetersToPoints(tbMargin)
tp.PageSetup.LeftMargin = WordApp.MillimetersToPoints(lrMargin)
tp.PageSetup.RightMargin = WordApp.MillimetersToPoints(lrMargin)

'使用在目的文件中所使用的樣式
WordApp.Selection.PasteAndFormat (wdUseDestinationStylesRecovery)

'段落置中
'Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter


'取得儲存格資料 並移除特殊符號
Dim sName As String, nName As String

Dim m As Integer

'將數文字轉成數字
m = CInt(c)

sName = tp.Tables(1).Cell(2, m).Range.Text

'移除表格儲存格最後面的2個特殊符號 ASCII 13 Carriage Return, ASCII 7 Bell
nName = Left(sName, Len(sName) - 2)

'Debug.Print nName
'Debug.Print Len(nName)

'儲存檔案
tp.SaveAs2 fileName:=nName & ".docx"

tp.Close

'將視窗切換到 工作檔案
WordDoc.Activate

'刪除表格的第2列資料
WordDoc.Tables(1).Rows(2).Delete

Next p
'for loop p end

'將視窗切換到 工作檔案
WordDoc.Activate

'關閉檔案 不儲存修改
WordDoc.Close SaveChanges:=wdDoNotSaveChanges

ElseIf c = "" Then
MsgBox "檔案名稱依據欄數未設定!!"
ElseIf Dir(fPath) = "" Then
MsgBox "檔案:" & fPath & "不存在，請查看是否有拼錯字"
End If
'
Next r
'for loop r end

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

Application.ScreenUpdating = True

End Sub