一键批量提取所有WORD中所有表格与段落的内容

考试加油站

提取表格内容部分

1. Sub 批量提取多个WORD内容正文按表格()
   
2.     Dim NEWD As Object, wddct As Object
   
3.     Dim f, arr, brr, i&, j&
   
4.     f = Application.GetOpenFilename(fileFilter:="Word文件(*.doc*),*.doc*", Title:="选择Word文件", MultiSelect:=True)
   
5.     If TypeName(f) = "Boolean" Then
   
6.         Exit Sub
   
7.     Else
   
8.         FPATH = Replace(f(1), Dir(f(1)), "")
   
9.     End If
   
10.     f = Dir(FPATH & "*.doc*")
    
11.     Set NEWD = CreateObject("Word.Application")
    
12.     i = 2
    
13.     Do Until f = ""                                   '只要文件名存在
    
14.         f = FPATH & f
    
15.         Set Wd = NEWD.Documents.Open(filename:=f)
    
16.         With Wd
    
17.             m = 1
    
18.             On Error Resume Next
    
19.             '提取每个表格内容
    
20.             For b = 1 To Wd.Tables.Count
    
21.                 For z = 1 To .Tables(b).Range.Cells.Count    '个单元格
    
22.                     st = .Tables(b).Range.Cells(z)
    
23.                     m = m + 1
    
24.                     Cells(i, m) = Trim(left(st, Len(st) - 2))
    
25.                     Cells(i, 1) = Wd
    
26.                 Next
    
27.             Next
    
28.         End With
    
29.         Set Wd = Nothing
    
30.         f = Dir
    
31.         i = i + 1
    
32.     Loop
    
33.     NEWD.Quit
    
34.     Set NEWD = Nothing
    
35.     Application.ScreenUpdating = True
    
36. End Sub
    

复制代码

测试文件.rar (41.93 KB, 下载次数: 194)

2020-11-24 11:18 上传

点击文件名下载附件

提取段落内容部分

1. Sub 批量提取多个WORD内容正文段落()
   
2.     Dim NEWD As Object, wddct As Object
   
3.     Dim f, arr, brr, i&, j&
   
4.     '选择文档开始
   
5.     f = Application.GetOpenFilename(fileFilter:="Word文件(*.doc*),*.doc*", Title:="选择Word文件", MultiSelect:=True)
   
6.     If TypeName(f) = "Boolean" Then
   
7.         Exit Sub
   
8.     Else
   
9.         FPATH = Replace(f(1), Dir(f(1)), "")
   
10.     End If
    
11.     f = Dir(FPATH & "*.doc*")
    
12. 
    
13.     Set NEWD = CreateObject("Word.Application")
    
14.     i = 2
    
15.     Do Until f = ""                                   '只要文件名存在
    
16.         f = FPATH & f
    
17.         Set Wd = NEWD.Documents.Open(Filename:=f)
    
18.         With Wd
    
19.             '横列提取每个段落内容
    
20.             On Error Resume Next
    
21.             For d = 1 To .Paragraphs.Count
    
22.                 st = .Paragraphs(d).Range.Text
    
23.                 Cells(i, d + 1) = Trim(Left(st, Len(st) - 2))    '横列提取
    
24.                 Cells(1, d + 1) = "第" & d & "段内容"
    
25.                 Cells(i, 1) = Wd
    
26.             Next
    
27.         End With
    
28.         Set Wd = Nothing
    
29.         f = Dir
    
30.         i = i + 1
    
31.     Loop
    
32.     NEWD.Quit
    
33.     Set NEWD = Nothing
    
34.     Application.ScreenUpdating = True
    
35. End Sub
    
36. 
    
37. 
    
38. 
    
39. 
    

复制代码

考试加油站

Sub 批量修改文件夹下WORD字体大小等()
    Dim strFileName As String, Fld
    Dim strPath As String
    Dim wApp As Object
    Dim wDoc As Object
    Set Fld = CreateObject("shell.application").BrowseForFolder(0, "请选择文件夹", 0)
    If Not Fld Is Nothing Then strPath = Fld.Self.path & "\"
    strFileName = Dir(strPath & "*.doc*")
    Set wApp = CreateObject("Word.Application")
    Do While strFileName <> ""
        Set wDoc = wApp.Documents.Open(strPath & strFileName)
        With wApp.Selection
            .WholeStory
            .Font.Bold = True                         '加粗
            .Font.Italic = True                       '斜体
            .Font.Underline = True                    '下划线
            .Range.HighlightColorIndex = 3            '高亮颜色
            .Font.Color = vbRed                       '字体颜色
            .Font.Size = 30                           '字体大小
        End With
        wDoc.Save
        wDoc.Close
        strFileName = Dir
    Loop
    Set wDoc = Nothing
    wApp.Quit
    Set wApp = Nothing
End Sub

考试加油站

Sub 原表格原位置提取到一张表()
    Dim tim2 As Date: tim1 = Timer
    Cells.ClearContents
    Cells.ClearContents
    Dim NEWD As Object, wddct As Object
    Dim F, arr, brr, i&, j&
    F = Application.GetOpenFilename(fileFilter:="Word文件(*.doc*),*.doc*", Title:="选择Word文件", MultiSelect:=True)
    If TypeName(F) = "Boolean" Then
        Exit Sub
    Else
        FPATH = Replace(F(1), Dir(F(1)), "")
    End If
    F = Dir(FPATH & "*.doc*")
    Set NEWD = CreateObject("Word.Application")
    Do Until F = ""                                   '只要文件名存在
        F = FPATH & F
        Set WD = NEWD.Documents.Open(Filename:=F)
        With WD
            On Error Resume Next
            '提取每个表格内容
            For b = 1 To WD.Tables.Count
                With .Tables(b)
                    r = WD.Tables(b).Rows.Count
                    C = WD.Tables(b).Columns.Count
                    ReDim arr(1 To r, 1 To C)
                    For i = 1 To r
                        For j = 1 To C
                            arr(i, j) = Application.Clean(WD.Tables(b).Cell(i, j).Range)
                        Next
                    Next
                End With
                X = Sheet1.UsedRange.Rows.Count + 1
                Sheet1.Cells(X, 2).Resize(r, C) = arr
                Sheet1.Cells(X, 1) = WD
            Next
            .Close False
        End With
        Set WD = Nothing
        F = Dir
    Loop
    NEWD.Quit
    Set NEWD = Nothing
    Application.ScreenUpdating = True
    tim2 = Timer
    MsgBox Format(tim2 - tim1, "提取完成，共耗时：0.00秒"), 64, "时间统计"
End Sub
测试文件.rar (45.76 KB, 下载次数: 155)

2020-12-16 20:52 上传

点击文件名下载附件

考试加油站

WORD中一张表格复制到一个EXCELL中

1. Sub 批量复制WORD表格EXCELL的多个表格中()
   
2. 
   
3.     Dim tim2 As Date: tim1 = Timer
   
4.     Cells.ClearContents
   
5.     Cells.NumberFormat = "@"
   
6. 
   
7.     Dim NEWD As Object, wddct As Object
   
8.     Dim F, arr, brr, i&, j&
   
9.     F = Application.GetOpenFilename(fileFilter:="Word文件(*.doc*),*.doc*", Title:="选择Word文件", MultiSelect:=True)
   
10.     If TypeName(F) = "Boolean" Then
    
11.         Exit Sub
    
12.     Else
    
13.         FPATH = Replace(F(1), Dir(F(1)), "")
    
14.     End If
    
15.     F = Dir(FPATH & "*.doc*")
    
16.     Set NEWD = CreateObject("Word.Application")
    
17.     i = 2
    
18.     Do Until F = ""                                   '只要文件名存在
    
19.         F = FPATH & F
    
20.         Set WD = NEWD.Documents.Open(Filename:=F)
    
21.         With WD
    
22.             WDN = Split(WD, ".")(0)
    
23.             On Error Resume Next
    
24.             '提取每个表格内容
    
25.             For Each TB In .Tables
    
26.                 N = N + 1
    
27.                 If N = 1 Then
    
28.                     Sheet1.Range("A1").Activate
    
29.                     TB.Range.Copy
    
30.                     Sheet1.Paste
    
31.                 Else
    
32.                     K = K + 1
    
33.                     Sheets.Add After:=Sheets(Sheets.Count)
    
34.                     Sheets(Sheets.Count).Name = WDN & "-" & K
    
35.                     TB.Range.Copy
    
36.                     Sheets(Sheets.Count).Paste
    
37.                 End If
    
38.                
    
39.             Next
    
40.         End With
    
41.         Set WD = Nothing
    
42.         F = Dir
    
43.         i = i + 1
    
44.     Loop
    
45.     NEWD.Quit
    
46.     Set NEWD = Nothing
    
47.     Application.ScreenUpdating = True
    
48.     tim2 = Timer
    
49.     MsgBox Format(tim2 - tim1, "提取完成，共耗时：0.00秒"), 64, "时间统计"
    
50. End Sub
    

复制代码

考试加油站

Sub 批量复制WORD表格到本表()
'更多下载www.15161218108.ys168.com
    Dim tim2 As Date: tim1 = Timer
    Cells.ClearContents
    Dim NEWD As Object, wddct As Object
    Dim F, arr, brr, i&, j&
    F = Application.GetOpenFilename(fileFilter:="Word文件(*.doc*),*.doc*", Title:="选择Word文件", MultiSelect:=True)
    If TypeName(F) = "Boolean" Then
        Exit Sub
    Else
        FPATH = Replace(F(1), Dir(F(1)), "")
    End If
    F = Dir(FPATH & "*.doc*")
    Set NEWD = CreateObject("Word.Application")
    i = 2
    Do Until F = ""                                   '只要文件名存在
        F = FPATH & F
        Set WD = NEWD.Documents.Open(filename:=F)
        With WD
            WDN = Split(WD, ".")(0)
            On Error Resume Next
            '提取每个表格内容
            For Each TB In .Tables
                N = N + 1
                If N = 1 Then
                    Range("B1").Activate
                    TB.Range.Copy
                    Sheet1.Paste
                Else
                    r = Sheet1.UsedRange.SpecialCells(11).Row + 1
                    Range("B" & r).Activate
                    TB.Range.Copy
                   Sheet1.Paste
                  ' Sheet1.PasteSpecial Format:="文本", Link:=False, DisplayAsIcon:=False
                   Sheet1.Selection.Borders.LineStyle = xlContinuous
                End If
                With Selection
                    BT = .Columns(1).Offset(, -1 * (.Column - 1)).Address
                    Range(BT) = WDN
                End With
            Next
        End With
        Set WD = Nothing
        F = Dir
        i = i + 1
    Loop
    NEWD.Quit
    Set NEWD = Nothing
    Application.ScreenUpdating = True
    tim2 = Timer
    MsgBox Format(tim2 - tim1, "提取完成，共耗时：0.00秒"), 64, "时间统计"
End Sub

考试加油站

Sub 批量转换WORD为PDF格式()   
'如不成功，可引用WORD控件
    Dim tim2 As Date: tim1 = Timer
    Dim F, myName, myName1 As String
    Dim SaveAsPDF As String
    Dim arr() As String
    Dim WD As Object
    Application.ScreenUpdating = False
    F = Application.GetOpenFilename(fileFilter:="Word文件(*.doc*),*.doc*", Title:="选择Word文件", MultiSelect:=True)
    If TypeName(F) = "Boolean" Then
        Exit Sub
    Else
        FPATH = Replace(F(1), Dir(F(1)), "")
    End If
    F = Dir(FPATH & "*.doc*")
    Set NEWD = CreateObject("Word.Application")
    Do Until F = ""                                   '只要文件名存在
        F = FPATH & F
        Set WD = NEWD.Documents.Open(filename:=F)
        With WD
            On Error Resume Next
            '取得每个word文档对象，以下命令可根据实际情况调整，此处为另存pdf
            arr = Split(F, ".")
            SaveAsPDF = arr(0) & Int(Rnd() * 1000) & ".pdf"
            WD.ExportAsFixedFormat outputfilename:=SaveAsPDF, exportformat:=wdExportFormatPDF
        End With
        Set WD = Nothing
        F = Dir
    Loop
    NEWD.Quit
    Set NEWD = Nothing
    Application.ScreenUpdating = True
    tim2 = Timer
    MsgBox Format(tim2 - tim1, "提取完成，共耗时：0.00秒"), 64, "时间统计"
End Sub

考试加油站

只复制WORD中其中一张表格内容

1. Sub 提取WORD中木一个表格到EXCELL中()
   
2. '更多下载www.15161218108.ys168.com
   
3.     Dim tim2 As Date: tim1 = Timer
   
4.     Dim JJ As Integer
   
5.     JJ = Application.InputBox("请输入想复制的工作是WORD中的第几个表！", "提示", , , , , , 1)
   
6.     Cells.ClearContents
   
7.    
   
8.     Dim NEWD As Object, wddct As Object
   
9.     Dim F, arr, brr, i&, j&
   
10.     F = Application.GetOpenFilename(fileFilter:="Word文件(*.doc*),*.doc*", Title:="选择Word文件", MultiSelect:=True)
    
11.     If TypeName(F) = "Boolean" Then
    
12.         Exit Sub
    
13.     Else
    
14.         FPATH = Replace(F(1), Dir(F(1)), "")
    
15.     End If
    
16.     F = Dir(FPATH & "*.doc*")
    
17.     Set NEWD = CreateObject("Word.Application")
    
18.     i = 2
    
19.     Do Until F = ""                                   '只要文件名存在
    
20.         F = FPATH & F
    
21.         Set WD = NEWD.Documents.Open(filename:=F)
    
22.         With WD
    
23.             WDN = Split(WD, ".")(0)
    
24.             On Error Resume Next
    
25.             '提取每个表格内容
    
26.             'x = Application.InputBox("请输入想复制的工作是WORD中的第几个表！", "提示", , , , , , 1)
    
27.             On Error Resume Next
    
28.             With .Tables(JJ)
    
29.                 N = N + 1
    
30.                 If N = 1 Then
    
31.                     Range("B1").Activate
    
32.                     .Range.Copy
    
33.                     Sheet1.Paste
    
34.                 Else
    
35.                     r = Sheet1.UsedRange.SpecialCells(11).Row + 1
    
36.                     Range("B" & r).Activate
    
37.                     .Range.Copy
    
38.                     Sheet1.Paste
    
39.                 End If
    
40.                 With Selection
    
41.                     BT = .Columns(1).Offset(, -1 * (.Column - 1)).Address
    
42.                     Range(BT) = WDN
    
43.                 End With
    
44.             End With
    
45.         End With
    
46.         Set WD = Nothing
    
47.         F = Dir
    
48.         i = i + 1
    
49.     Loop
    
50.     NEWD.Quit
    
51.     Set NEWD = Nothing
    
52.     Application.ScreenUpdating = True
    
53.     tim2 = Timer
    
54.     MsgBox Format(tim2 - tim1, "提取完成，共耗时：0.00秒"), 64, "时间统计"
    
55. End Sub
    

复制代码

考试加油站

测试文件.rar (68.02 KB, 下载次数: 253)

2020-12-17 16:54 上传

点击文件名下载附件

machunze

感谢分享，但是死机了
“excel 正在等待其它某个应用程序以完成对象链接与嵌入操作”

f8b1987

对word的对象属性一直不了解。
如果要提前某一段话，或者搜索某个字符串，怎么处理呢

考试加油站

此处删除，合并到首页贴

考试加油站

f8b1987 发表于 2020-11-23 17:17
对word的对象属性一直不了解。
如果要提前某一段话，或者搜索某个字符串，怎么处理呢

WORD我也不是很了解，也是学习中，觉得不错，分享一下

qlmgu

两个程序都挺好用，适应性广，多谢了。

kuanggx

能否保留WORD中 表格的格式 呢？

aecn

WORD的还没接触过，感谢分享

wang-way

f8b1987 发表于 2020-11-23 17:17
对word的对象属性一直不了解。
如果要提前某一段话，或者搜索某个字符串，怎么处理呢

如果是一个段落 那就遍历段落，如果只是当中的一段内容，查找