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

 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

 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

 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

 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