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

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

Post Views: 557

分別說明如後

報名表格式

每一個課程的第一個表格是主題與時數

之後是報名資料表格

備註：資料都是假的，從個資、姓名產生器抓來的

工作表格式

取得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
Pages: 1 2 3
Tags: