通过宏是否可以把WORD表格的相关内容粘贴到汇总表末尾

lqw29

通过宏是否可以把WORD表格的相关内容粘贴到汇总表末尾 报名.rar (17.88 KB, 下载次数: 8)

2024-9-14 20:43 上传

点击文件名下载附件

songshihai

1. Sub 批量读取word中的表格到excel()
   
2.     Dim arr(), brr(1 To 1, 1 To 15)
   
3.     Set wdApp = CreateObject("kwps.Application")
   
4.     wdApp.Visible = False ' 不显示Word应用程序
   
5.     On Error Resume Next
   
6.     Columns("N:N,P:P").NumberFormatLocal = "@"
   
7.     Set Rng = Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
   
8.     Set fd = Application.FileDialog(1)
   
9.     fd.AllowMultiSelect = True
   
10.     fd.Filters.Clear
    
11.     fd.Title = "选择word文件,可多选!"
    
12.     If fd.Show <> -1 Then MsgBox "未选择文件,退出程序!": Exit Sub
    
13.     For b = 1 To fd.SelectedItems.Count
    
14.         路径 = fd.SelectedItems(b)
    
15.         If Right(路径, 3) = "doc" Or Right(路径, 4) = "docx" Then
    
16.             Set wdDoc = wdApp.Documents.Open(路径)
    
17.             Set wdTbl = wdDoc.Tables(1)
    
18.             ReDim arr(1 To wdTbl.Rows.Count, 1 To wdTbl.Columns.Count)
    
19.             brr(1, 1) = Application.Clean(wdTbl.Cell(3, 2).Range.Text)
    
20.             brr(1, 2) = Application.Clean(wdTbl.Cell(3, 4).Range.Text)
    
21.             brr(1, 4) = Application.Clean(wdTbl.Cell(5, 4).Range.Text)
    
22.             brr(1, 5) = Application.Clean(wdTbl.Cell(5, 2).Range.Text)
    
23.             brr(1, 6) = Application.Clean(wdTbl.Cell(6, 2).Range.Text)
    
24.             brr(1, 8) = Application.Clean(wdTbl.Cell(6, 4).Range.Text)
    
25.             brr(1, 9) = Mid(Application.Clean(wdTbl.Cell(11, 2).Range.Text), 15, 10000)
    
26.             brr(1, 13) = Application.Clean(wdTbl.Cell(8, 4).Range.Text)
    
27.             brr(1, 15) = Application.Clean(wdTbl.Cell(7, 6).Range.Text)
    
28.             Rng.Resize(1, 15) = brr
    
29.             Set Rng = Cells(Rows.Count, 1).End(xlUp).Offset(2, 0)
    
30.             Erase arr
    
31.             wdDoc.Close SaveChanges:=False
    
32.         End If
    
33.     Next b
    
34.     wdApp.Quit
    
35.     MsgBox "完成!"
    
36. End Sub
    

复制代码

lqw29

songshihai 发表于 2024-9-14 23:24

太感谢大神了，完全按照您的代码搞定了，只是我手拙捣鼓了好一会儿，多谢多谢。

lqw29

songshihai 发表于 2024-9-14 23:24

运行宏，如果同时选择打开多个word表格文件，从第二条粘贴的内容开始，左侧少留一个单元格了，而如果每次只选一个文件，就没问题，想请大神帮忙解决，谢谢。 报名继续.rar (67.38 KB, 下载次数: 2)

2024-9-27 23:22 上传

点击文件名下载附件

taller

1. Sub 批量读取word中的表格到excel()
   
2.     Dim arr(), brr(1 To 1, 1 To 15)
   
3.     Set wdApp = CreateObject("word.Application")
   
4.     wdApp.Visible = True 'False ' 不显示Word应用程序
   
5.      On Error Resume Next
   
6.     Columns("N:N,P:P").NumberFormatLocal = "@"
   
7.     On Error GoTo 0
   
8.     Set Rng = Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
   
9.     Set fd = Application.FileDialog(1)
   
10.     fd.AllowMultiSelect = True
    
11.     fd.Filters.Clear
    
12.     fd.Title = "选择word文件,可多选!"
    
13.     If fd.Show <> -1 Then MsgBox "未选择文件,退出程序!": Exit Sub
    
14.     For b = 1 To fd.SelectedItems.Count
    
15.         路径 = fd.SelectedItems(b)
    
16.         If Right(路径, 3) = "doc" Or Right(路径, 4) = "docx" Then
    
17.             Set wdDoc = wdApp.Documents.Open(路径)
    
18.             Set wdTbl = wdDoc.Tables(1)
    
19.             ReDim arr(1 To wdTbl.Rows.Count, 1 To wdTbl.Columns.Count)
    
20.             brr(1, 1) = Application.Clean(wdTbl.Cell(3, 2).Range.Text)
    
21.             
    
22.             brr(1, 2) = Application.Clean(wdTbl.Cell(3, 4).Range.Text)
    
23.             brr(1, 4) = Application.Clean(wdTbl.Cell(5, 4).Range.Text)
    
24.             brr(1, 5) = Application.Clean(wdTbl.Cell(5, 2).Range.Text)
    
25.             brr(1, 6) = Application.Clean(wdTbl.Cell(6, 2).Range.Text)
    
26.             brr(1, 8) = Application.Clean(wdTbl.Cell(6, 4).Range.Text)
    
27.             brr(1, 9) = Mid(Application.Clean(wdTbl.Cell(11, 2).Range.Text), 15, 10000)
    
28.             brr(1, 13) = Application.Clean(wdTbl.Cell(8, 4).Range.Text)
    
29.             brr(1, 15) = Application.Clean(wdTbl.Cell(7, 6).Range.Text)
    
30.             Rng.Resize(1, 15) = brr
    
31.             Set Rng = Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
    
32.             Erase arr
    
33.             wdDoc.Close SaveChanges:=False
    
34.         End If
    
35.     Next b
    
36.     wdApp.Quit
    
37.     MsgBox "完成!"
    
38. End Sub
    
39. 
    

复制代码

lqw29

taller 发表于 2024-9-28 02:53

完全用你的vba解决了问题，谢谢大神，谢谢