2024/09/07

VBA / Excel 使用VBA取得word檔案內表格資料

由於辦理縣市薦派人員性質的研習
這種研習通常會設計制式表格給縣市承辦人填寫
而因為報名表格需要層層核章，再加上公文傳遞只能用pdf格式或者odf格式(odt文件)
所以通常會用odt文件來製作報名表，讓承辦人可以填寫並核章
以後有時間再來設計一個線上google表單
讓承辦人填寫完之後，可以一鍵輸出pdf或者odt文件 這樣既可以紙本核章，我也可以快速取得報名資料
回到主題，這次的練習是透過Excel VBA來取得word文件(docx或odt)內表格的資料
撰寫的程式碼主要都是在處理表格資料，這也是因為要考慮到公文傳遞只能用 odf格式(odt文件) 
不然的話，可以在word設計activeX表單，來限制表格的填寫，這樣後期整理資料也比較容易 
整體程式流程可以分為 
1.開啟目標檔案 
2.抓取表格資料 
3.處理表格資料 
4.輸出到工作表

分別說明如後

報名表格式

每一個課程的第一個表格是主題與時數 
之後是報名資料表格
備註：資料都是假的，從個資、姓名產生器抓來的

工作表格式

取得word表格資料後，依序寫入工作表 備註：資料也都是假的，從個資、姓名產生器抓來的  

Excel VBA程式

#3-12 
透過早期繫結的方式來宣告並建立word物件 

#7-12
確保真的有建立物件 
之前因為沒有這段程式碼，導致沒有建立物件 
程式雖然可以往後跑，但是在處理word內的資料時
就會造成無法使用word物件的錯誤 
 
#14 
設定為true是方便觀察程式的進行
可以設定為false，不要顯示word文件 

#18-26 
透過自訂函數cmdSelectFile()來取得目標檔案的路徑
如果沒有選取檔案會得到回傳數值0 
但是有選取檔案就會得到檔案路徑的陣列
所以這邊的變數是宣告為Variant 

#27-133 
整體程式的迴圈，選取多少word檔案就跑幾次 

#30-31 
取得目前工作表上有資料的列數，+1是新增資料要放的位置

#35-39 開啟word檔 

#43-128
抓取word表格資料的迴圈，有多少表格就跑多少次


關隘所在

excel也有table，word也有table
因為是在excel裡操控word物件，所以word物件都要明確定義，例如：word.table

c1是表格的第1列第1欄 
c2是表格的第2列第1欄 
如果c1是主題則表示是報名表的第1個表格 
如果c1是姓名則表示是報名表上的報名資料表格 
c2是對應姓名的填寫欄位，如果不是空的，表示這個項目有資料 

之後都是處理表格資料 
這邊用到3個自訂函數 
rAll()，處理資料內的換行符號跟空白 
fS2()，處理核取方塊 
tsFn()，處理word table' 抓取表格前一段落的文字

  
  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
Sub 抓取表格資料13()
    ' 宣告物件
    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 fArr As Variant
    
    fArr = cmdSelectFile()
'    Debug.Print TypeName(fArr)
    '有選取檔案 回傳檔案路徑的陣列 TypeName->String()
    '沒有選取檔案 回傳數值 0 TypeName->Integer
    
    If TypeName(fArr) = "Integer" Then
        Debug.Print "請確認是否選取檔案"
        Exit Sub
    End If
    Dim i As Integer
    
    For i = 0 To UBound(fArr)
        Dim r As Integer
        r = Sheets(1).Range("A1000").End(xlUp).Row + 1
        
        ' Debug.Print fArr(i)
    
        ' 打開Word文檔
        Dim fPath As String
        fPath = fArr(i)
        
        Set WordDoc = WordApp.Documents.Open(Filename:=fPath)
        
        Dim ts As Word.Table
        
        For Each ts In WordDoc.Tables
            DoEvents
            
            Dim c1 As String
            Dim c2 As String
            
            c1 = ts.Cell(1, 1).Range.Text
            c1 = Left(c1, Len(c1) - 2)
            c1 = Replace(c1, " ", "")
            
            c2 = ts.Cell(2, 1).Range.Text
            c2 = Left(c2, Len(c2) - 2)
            c2 = Replace(c2, " ", "")
            
            'Debug.Print c1
            If c1 = "主題" Then
                Dim x As String
                x = tsFn(ts)
                
            End If
            
            If c1 = "姓名" And c2 <> "" Then
                '宣告arr1陣列 長度為0-7
                Dim arr1(7) As String
                Dim cName As String
                Dim cServ As String
                Dim cTitle As String
                Dim cPhone As String
                Dim cMail As String
                Dim cFood As String
                Dim cRn As String
                Dim cSub As String
                
                cName = ts.Cell(2, 1).Range.Text
                cName = Left(cName, Len(cName) - 2)
    '            Debug.Print cName
                arr1(0) = rAll(cName)
                
                cServ = ts.Cell(2, 2).Range.Text
                cServ = Left(cServ, Len(cServ) - 2)
    '            Debug.Print cServ
                arr1(1) = rAll(cServ)
    
                cTitle = ts.Cell(2, 3).Range.Text
                cTitle = Left(cTitle, Len(cTitle) - 2)
    '            Debug.Print cTitle
                arr1(2) = rAll(cTitle)
                
                cPhone = ts.Cell(2, 4).Range.Text
                cPhone = Left(cPhone, Len(cPhone) - 2)
    '            Debug.Print cPhone
    '            Debug.Print TypeName(cPhone)
                arr1(3) = rAll(cPhone)
                
                cMail = ts.Cell(2, 5).Range.Text
                cMail = Left(cMail, Len(cMail) - 2)
    '            Debug.Print cMail
                arr1(4) = rAll(cMail)
                
                cFood = ts.Cell(2, 6).Range.Text
                cFood = Left(cFood, Len(cFood) - 2)
    '            Debug.Print cFood
    '            Debug.Print fS(cFood)
                arr1(5) = rAll(fS2(cFood))
                
                cRn = ts.Cell(4, 1).Range.Text
                cRn = Left(cRn, Len(cRn) - 2)
    '            Debug.Print cTimes
    '            Debug.Print fS(cTimes)
                arr1(6) = rAll(fS2(cRn))
                
'                cSub = ts.Cell(4, 1).Range.Text
'                cSub = Left(cSub, Len(cSub) - 2)
'    '            Debug.Print cSub
'    '            Debug.Print fS(cSub)
'                arr1(7) = rAll(fS(cSub))

                 cSub = x & tsFn(ts)
                
                arr1(7) = rAll(cSub)
                
                Sheets("工作表1").Range("A" & r & ":H" & r).Value = arr1
                
                r = r + 1
            End If
        Next ts

        ' 關閉並不保存Word文檔
        WordDoc.Close SaveChanges:=False
        
    Next i
'    Debug.Print i
    ' 關閉Word應用程序
    WordApp.Quit

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

自訂函數

cmdSelectFile()，選取檔案並回傳檔案路徑

#2-10 
宣告檔案對話框 

#14-30 
處理選取的檔案項目 
如果有選取，>0，寫入陣列fileArr 
如果沒有選取，設定回傳數值為0

  
 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
 
Function cmdSelectFile() As Variant
    Dim fd As FileDialog    '宣告一個檔案對話框
    Set fd = Application.FileDialog(msoFileDialogFilePicker)  '設定選取檔案功能
    
    fd.Filters.Clear    '清除之前的資料
    
    fd.InitialFileName = ActiveWorkbook.Path & Application.PathSeparator '設定初始目錄
    
    fd.Filters.Add "Word File", "*.doc*; *.odt" '設定顯示的副檔名
    fd.Filters.Add "所有檔案", "*.*"
        
    fd.Show '顯示對話框
    
    Dim f As Integer
    f = fd.SelectedItems.Count
     
    If f > 0 Then
        Dim i As Integer
        Dim fileArr() As String
    
        For i = 0 To f - 1
            Dim strFullName As String
            ReDim Preserve fileArr(i)
            fileArr(i) = fd.SelectedItems(i + 1)            
        Next i

        cmdSelectFile = fileArr
    Else
        cmdSelectFile = 0
    End If

End Function
 

rAll()，處理資料內的換行符號跟空白

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
 
Function rAll(ByVal x As String) As String

    x = Replace(x, Chr(32), "")
    x = Replace(x, vbLf, "")
    x = Replace(x, vbCr, "")
    x = Replace(x, vbCrLf, "")
    x = Replace(x, vbNewLine, "")
    
    rAll = x
End Function

fS2()，處理核取方塊

#9-16 
處理資料內是否有冒號"：" 
這是因為之前版本的報名表有個欄位內容是「學科類別： □國中國語文 □國中英語文 □國中數學」 
如果有冒號就用Split()分割並取得冒號後面的字串 

#29-31 
透過迴圈將字串轉為字串陣列 charArray 

#33-47 
透過正則表達式來逐一比對字串陣列 charArray內的資料 
如果非中文字就把序號(位置)記錄下來，存在陣列 charArray2 

#49-61 
透過 charArray2紀錄的序號位置，以mid()來分割字串 

#63-69 
處理字串最後會有","的狀況，暫時想不到更好的方式，只好土炮用直接判斷最後一個字是不是","
以及假如沒有勾選的時候，顯示為"無資料"

  
 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
 
Function fS2(ByVal FindText As String) As String
    Dim t1 As String
    Dim t2 As String
    Dim t3 As String
    Dim itext1 As Integer
    
    t1 = FindText
    
    itext1 = InStr(t1, Chr(41287))
    
    If Not itext1 = 0 Then
        t2 = Split(t1, Chr(41287))(1)
        t3 = rAll(t2)
    Else
        t3 = rAll(t1)
    End If
      
    Dim charArray() As String
    ReDim charArray(Len(t3) - 1)
    
    Dim charArray2() As Integer
    ReDim charArray2(0)
    
    Dim i As Integer
    Dim j As Integer
    Dim q As Integer
    Dim r As Integer
    
    For i = 1 To Len(t3)
        charArray(i - 1) = Mid(t3, i, 1)
    Next
    
    Dim objRegEx As Object
    Set objRegEx = CreateObject("vbscript.regexp")
    objRegEx.Pattern = "[\u4e00-\u9fa5]"  '所有中文字
    objRegEx.Global = True
    objRegEx.IgnoreCase = True
    
    j = 0
    
    For q = 1 To Len(t3)
        If objRegEx.test(Mid(t3, q, 1)) <> True Then
            ReDim Preserve charArray2(j)
            charArray2(j) = q
            j = j + 1
        End If
    Next q
    
    Dim outTest As String
    outText = ""
        
    For r = 0 To UBound(charArray2)
        If r < UBound(charArray2) And InStr(charArray(charArray2(r) - 1), Chr(41404)) = 0 Then

                outText = outText & Mid(t3, charArray2(r) + 1, charArray2(r + 1) - charArray2(r) - 1) & ","

        ElseIf r = UBound(charArray2) And InStr(charArray(charArray2(r) - 1), Chr(41404)) = 0 Then

                outText = outText & Mid(t3, charArray2(r) + 1)
        End If
    Next r

    If outText <> "" Then
        If Mid(outText, Len(outText)) = "," Then
            outText = Left(outText, Len(outText) - 1)
        End If
    Else
        outText = "無資料"
    End If
    
    fS2 = outText
    
End Function
 

tsFn()，處理word table' 抓取表格前一段落的文字

#3-10 
宣告word物件以操控word表格 

#12 
選取word表格 

#21 
從表格往上2個段落到開端(因為從表格本身開始為1) 

#23 從目前的段落開端選取到最後 

#29-33 
處理字串的空白

  
 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
Function tsFn(ByVal x As Table) As String
            
            ' 宣告物件
            Dim WordApp As Word.Application

            ' 創建一個新的Word應用程序對象
            On Error Resume Next
            Set WordApp = GetObject(, "Word.Application")
            If Err.Number > 0 Then Set WordApp = CreateObject("Word.Application")
            On Error GoTo 0
            
            x.Select
            
            'error-438-for-vba-word-when-using-selectrow-does-vba-not-reconize-open-word
            'https://stackoverflow.com/a/52932183/24186217
            
            'run-time-error-462-the-remote-server-machine-does-not-exist-or-is-unavailable
            'https://stackoverflow.com/a/33633870/24186217
            
'            Word.Application.Selection.MoveUp unit:=wdParagraph, Count:=2
            WordApp.Selection.MoveUp unit:=4, Count:=2
'            Word.Application.Selection.MoveDown unit:=wdParagraph, Extend:=wdExtend
            WordApp.Selection.MoveDown unit:=4, Extend:=1
            
            'Selection.Range Type Mismatch
            'https://stackoverflow.com/q/24614732/24186217
            'It looks like you are running this procedure from another application (Excel, maybe?).
            'If so, try: Dim HeadingRange() As Word.Range –David Zemens
            Dim rStart As Word.Range
            Set rStart = WordApp.Selection.Range
            
            Dim rString As String
            rString = rAll(rStart)
            
            Debug.Print rString
            Set WordApp = Nothing
            
            tsFn = rString
End Function
  
在excel操控word物件的限制很多，或許不能說是限制 
而是必須明確定義物件，這樣才能如實地操控到目標物件

0 comments:

張貼留言

訂閱： 張貼留言 (Atom)