求助将word表格内容通过VBA提取到excel

wx486

1. Sub Doc2Excel()
   
2. Dim i%, j%, k%, iCellCount%, arr(), brr(), tbl, cell As cell, exApp As Object, sht, file
   
3. 
   
4. On Error Resume Next
   
5. With Application.FileDialog(msoFileDialogFilePicker)
   
6.     .Filters.Clear
   
7.     .Filters.Add "所有WORD文件", "*.doc,*.docx", 1
   
8.     .AllowMultiSelect = True
   
9.     If .Show <> -1 Then Exit Sub
   
10.     For Each file In .SelectedItems
    
11.         With GetObject(file)
    
12.             If .Tables.Count = 1 Then
    
13.                 j = 0
    
14.                 k = k + 1
    
15.                 Set tbl = .Tables(1)
    
16.                 iCellCount = tbl.Range.Cells.Count
    
17.                 ReDim Preserve arr(1 To 500, 1 To iCellCount / 2)
    
18.                 ReDim Preserve brr(1 To iCellCount / 2)
    
19.                 If k = 1 Then
    
20.                     For i = 1 To iCellCount
    
21.                         If i Mod 2 Then brr((i + 1) / 2) = Replace(tbl.Range.Cells(i).Range.Text, Chr(13) & Chr(7), "")
    
22.                     Next i
    
23.                 End If
    
24.                 For i = 1 To iCellCount
    
25.                     If i Mod 2 = 0 Then
    
26.                         j = j + 1
    
27.                         arr(k, j) = Replace(tbl.Range.Cells(i).Range.Text, Chr(13) & Chr(7), "")
    
28.                     End If
    
29.                 Next i
    
30.             End If
    
31.             .Close False
    
32.         End With
    
33.     Next
    
34. End With
    
35. 
    
36. Set exApp = GetObject(, "excel.application")
    
37. If Err <> 0 Then
    
38.     Err.Clear
    
39.     Set exApp = CreateObject("excel.application")
    
40. End If
    
41. Set sht = exApp.Workbooks.Open(ThisDocument.Path & "" & "New Microsoft Excel Worksheet.xlsx").sheets(1)
    
42. sht.Cells.Clear
    
43. sht.[a1].Resize(1, UBound(brr)) = brr
    
44. ReDim Preserve arr(1 To k, 1 To iCellCount / 2)
    
45. sht.[a2].Resize(k, UBound(brr)) = arr
    
46. sht.Parent.Close True
    
47. 'sht.Parent.Windows(1).Visible = True
    
48. exApp.Quit
    
49. Set exApp = Nothing
    
50. MsgBox "OK!"
    
51. End Sub

复制代码