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

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

Post Views: 368

之前在「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

 

Tags: