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