Word / 使用VBA分割word內的表格

Word / 使用VBA分割word內的表格

Post Views: 233

最近收到一個有審查意見的word檔

從內容看起來，老師應該是從excel複製貼上的

(圖示裡面的個資都是來自假文產生器，並不是實際檔案)

但是因為要分別給不同的人員

當然可以純手工分割這些表格(我一開始也是這樣)

不過由於這個過程還蠻規律的

1.複製第1列+第2列

2.開新檔案

3.用其中一個欄位的內容為檔案名稱

4.存檔

5.回到原檔案

6.刪掉第2列資料

7.然後再複製第1列 跟 新的第2列資料

重複1~6

所以在純手工之後，嘗試以VBA來處理這個流程

版本1，將原始檔案另存成docm 啟用巨集的格式，編輯與執行VBA

備註：因為程式是直接寫在檔案內，所以在測試時很容易忘記先存檔

然後最後就關閉檔案…

 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
 
Public Sub 表格分割()
    '取得工作檔案名稱
    Dim workFile As String
    workFile = ActiveDocument.Name
    pathFile = ActiveDocument.Path & Application.PathSeparator & ActiveDocument.Name
    
    '指定文件夾
    'ChangeFileOpenDirectory "C:\Users\edu\Documents\"
    Dim fDialog As FileDialog
    
    ' 建立選擇目錄的對話方塊
    Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
    
    If fDialog.Show Then
    ' 顯示選擇的目錄
        'MsgBox fDialog.SelectedItems(1)
        ChangeFileOpenDirectory fDialog.SelectedItems(1)
    End If

    'ActiveDocument.Tables(1).Select
    Dim mytable As Table
    Set mytable = ActiveDocument.Tables(1)
   
    'Debug.Print mytable.Rows.Count
    
    ' for loop start
    Dim i As Integer
    
    For i = 2 To mytable.Rows.Count
        ActiveDocument.Range(mytable.Rows(1).Range.Start, mytable.Rows(2).Range.End).Select
        
        Selection.Copy
        
        '新增檔案
        Documents.Add Template:="Normal", NewTemplate:=False, DocumentType:=0
        
        '橫式頁面
        If ActiveDocument.PageSetup.Orientation = wdOrientPortrait Then
            ActiveDocument.PageSetup.Orientation = wdOrientLandscape
        Else
            ActiveDocument.PageSetup.Orientation = wdOrientPortrait
        End If
        
        '使用在目的文件中所使用的樣式
        Selection.PasteAndFormat (wdUseDestinationStylesRecovery)
        
        'Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
        
        '指定的表格 在頁面置中
        ActiveDocument.Tables(1).Rows.Alignment = wdAlignRowCenter
        
        '取得儲存格資料 並移除特殊符號
        Dim sName As String
        Dim nName As String
        
        sName = ActiveDocument.Tables(1).Cell(2, 1).Range.Text
        
        '移除表格儲存格最後面的2個特殊符號 ASCII 13 Carriage Return, ASCII 7 Bell
        nName = Left(sName, Len(sName) - 2)
        
        'Debug.Print nName
        'Debug.Print Len(nName)
        
        ActiveDocument.SaveAs2 FileName:=nName & ".docx"
                
        ActiveDocument.Close
        
        '將視窗切換到 工作檔案
        Documents(workFile).Activate
                    
        '刪除表格的第2列資料
        ActiveDocument.Tables(1).Rows(2).Delete
        
     Next i:
    'for loop end
    
     MsgBox "完成，即將關閉檔案"
     
     '不存檔 關閉整個word程式
     Application.Quit SaveChanges:=wdDoNotSaveChanges
    
End Sub

 

版本2，新增一個docm檔案，將原始檔案作為資料來源

部分程式碼是取自 VBA / 使用Word VBA批次轉換成PDF

主要是修改”開始分割表格”的程式碼

備註：ActivaX按鈕的程式碼必須綁定按鈕，也就是程式碼是觸動事件要執行的內容，這在excel也是一樣的用法

(excel還多了2個可以設定執行程式的方式：1.用舊表單的按鈕、2.圖形，都可以指定巨集)

而且程式碼是寫在檔案本身(ThisDocument)，而不是在模組

  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
 
Private Sub cmdGO_Click()

    Application.ScreenUpdating = False
    
    Dim i As Integer, j As Integer, f As String, r As String
    
    i = 2
    j = 2
        
    'VBA程式所在的檔案資訊
    Dim FileName As String
    FileName = ActiveDocument.Name
    
    '取出表格內的檔案
    '檔案路徑
    f = Documents(FileName).Tables(1).Cell(i, 2).Range.Text
    '新增檔案命名的依據
    r = Documents(FileName).Tables(1).Cell(i, 3).Range.Text
    
    '去掉word表格內的非列印字元
    f = Left(f, Len(f) - 2)
    r = Left(r, Len(r) - 2)
    
    If f <> "" And r <> "" Then
        While f <> "" And i <= Documents(FileName).Tables(1).Rows.Count
           '檢查檔案是否存在
            If Dir(f) <> "" Then
                '開啟表格內的檔案
                Documents.Open FileName:=f
                
                '取得檔案名稱
                Dim workFile As String
                workFile = ActiveDocument.Name
                
                '取得邊界
                tbMargin = PointsToMillimeters(ActiveDocument.PageSetup.TopMargin)
                lrMargin = PointsToMillimeters(ActiveDocument.PageSetup.RightMargin)
                
                '設定工作資料夾
                '建立選擇目錄的對話方塊
                Dim fDialog As FileDialog
                
                Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
                
                fDialog.Filters.Clear
                
                fDialog.InitialFileName = ActiveDocument.Path & Application.PathSeparator
                
                If fDialog.Show Then
                    '顯示選擇的目錄
                    'MsgBox fDialog.SelectedItems(1)
                    ChangeFileOpenDirectory fDialog.SelectedItems(1)
                End If
                            
                Dim mytable As Table
                Set mytable = ActiveDocument.Tables(1)
               
                'Debug.Print mytable.Rows.Count
                
                ' for loop start
                Dim p As Integer
                
                For p = 2 To mytable.Rows.Count
                    ActiveDocument.Range(mytable.Rows(1).Range.Start, mytable.Rows(2).Range.End).Select
                    
                    Selection.Copy
                    '建立新檔案
                    Documents.Add Template:="Normal", NewTemplate:=False, DocumentType:=0
                    
                    'Debug.Print ActiveDocument.Name
                    
                    '橫式頁面
                    If ActiveDocument.PageSetup.Orientation = wdOrientPortrait Then
                        ActiveDocument.PageSetup.Orientation = wdOrientLandscape
                    Else
                        ActiveDocument.PageSetup.Orientation = wdOrientPortrait
                    End If
                    
                    '設定邊界
                    ActiveDocument.PageSetup.TopMargin = MillimetersToPoints(tbMargin)
                    ActiveDocument.PageSetup.BottomMargin = MillimetersToPoints(tbMargin)
                    ActiveDocument.PageSetup.LeftMargin = MillimetersToPoints(lrMargin)
                    ActiveDocument.PageSetup.RightMargin = MillimetersToPoints(lrMargin)
                    
                    '使用在目的文件中所使用的樣式
                    Selection.PasteAndFormat (wdUseDestinationStylesRecovery)
                                    
                    '段落置中
                    'Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
                    
                    '指定的表格 在頁面置中 (所有資料列置中)
                    ActiveDocument.Tables(1).Rows.Alignment = wdAlignRowCenter
                                    
                    '取得儲存格資料 並移除特殊符號
                    Dim sName As String, nName As String
                    
                    Dim m As Integer
                    
                    '將數文字轉成數字
                    m = CInt(r)
                    
                    sName = ActiveDocument.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)
                    
                    '儲存檔案
                    ActiveDocument.SaveAs2 FileName:=nName & ".docx"
                                   
                    ActiveDocument.Close
                    
                    '將視窗切換到 工作檔案
                    Documents(workFile).Activate
                    
                    '刪除表格的第2列資料
                    ActiveDocument.Tables(1).Rows(2).Delete
                    
                 Next p:
                'for loop end
                
                '將視窗切換到 工作檔案
                 Documents(workFile).Activate
                 
                 '關閉檔案 不儲存修改
                 ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
                    
            Else
                 MsgBox "檔案:" & f & "不存在，請查看是否有拼錯字"
            End If
            
            i = i + 1
            f = Documents(FileName).Tables(1).Cell(i, 2).Range.Text
            f = Left(f, Len(f) - 2)
            
            '釋放CPU資源 可以執行其他程序
            DoEvents
                    
        Wend
        
        MsgBox "執行完成"
        
    Else
        MsgBox "請確認表格資料是否完整!!"
        
    End If
        
    Application.ScreenUpdating = True
    
End Sub

 

Tags: