怎么提取word内容

武松打鼓

怎么才能只提取word文件内容“：”右侧 的信息到excel表中


提取信息.rar (301.55 KB, 下载次数: 22)

2023-6-19 18:17 上传

点击文件名下载附件

donghui2363

你的excel的列名为何和word里的不一致？

武松打鼓

donghui2363 发表于 2023-6-19 19:48
你的excel的列名为何和word里的不一致？

大同小异呢，现在改成相同的字段了，你看看可以搞定吗。

提取信息.zip (298.19 KB, 下载次数: 7)

2023-6-19 21:48 上传

点击文件名下载附件

liulang0808

Sub test()

    ChDrive Left(ThisWorkbook.FullName, 1) '点击导入按钮，指向当前盘
    ChDir ThisWorkbook.Path '指向当前路径

    f = Application.GetOpenFilename("Microsoft Office word 文件 (*.doc*),*.doc*", , "请选择要导入的数据：")  '打开对话框，选择一个文件f
    If f = False Then
        MsgBox "本次没有选择任何文件！"
        Exit Sub
    End If
   
    Set wdapp = CreateObject("word.application")
   
    Set wb = wdapp.Documents.Open(f)
   
    arr = Split(wb.Range, Chr(13))
    wb.Close
    brr = Sheets(2).[a1].CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    For j = 2 To UBound(brr, 2)
        d(brr(1, j)) = j
    Next
    For Each k In arr
        If InStr(k, ":") > 0 Then
            crr = Split(WorksheetFunction.Clean(k), ":")
            s = WorksheetFunction.Clean(crr(0))
            If d.exists(s) Then brr(1, d(s)) = crr(1)
        End If
    Next k
    brr(1, 1) = UBound(brr)
    Sheets(2).Cells(UBound(brr) + 1, 1).Resize(1, UBound(brr, 2)) = brr
End Sub

liulang0808

供参考。。。。。

武松打鼓

liulang0808 发表于 2023-6-19 22:12
Sub test()

    ChDrive Left(ThisWorkbook.FullName, 1) '点击导入按钮，指向当前盘

确实不错，太高深了。可惜看不明白，大侠能不能给注解一下，学习学习？

aecn

1. 
   
2. Sub test()
   
3.     ChDrive Left(ThisWorkbook.FullName, 1)   '将当前工作簿所在的磁盘盘符设置为活动状态
   
4.     ChDir ThisWorkbook.Path   '将当前的工作目录设置为当前工作簿所在的目录
   
5.     f = Application.GetOpenFilename("Microsoft Office word 文件 (*.doc*),*.doc*", , "请选择要导入的数据：")  '打开对话框，选择一个文件f
   
6.     If f = False Then   '如果没有选择任何文件，则提示信息并退出
   
7.         MsgBox "本次没有选择任何文件！"
   
8.         Exit Sub
   
9.     End If
   
10.    
    
11.     Set wdapp = CreateObject("word.application")   '创建一个Word应用程序对象
    
12.     Set wb = wdapp.Documents.Open(f)   '打开文件f并将其赋值给wb
    
13.     '将wb中的文本按照回车符分割成一个字符串数组
    
14.     arr = Split(wb.Range, Chr(13))
    
15.     wb.Close   '关闭wb
    
16.     brr = Sheets(2).[a1].CurrentRegion   '获取工作表2中从单元格A1开始的当前区域
    
17.     '创建一个字典d，将brr中第一行的每个单元格的值作为键，对应的列号作为值
    
18.     Set d = CreateObject("scripting.dictionary")
    
19.     For j = 2 To UBound(brr, 2)
    
20.         d(brr(1, j)) = j
    
21.     Next
    
22.     '遍历数组arr，如果字符串包含冒号，则将字符串分割成一个字符串数组crr，并将第一个元素作为键s，第二个元素作为值写入到brr中
    
23.     For Each k In arr
    
24.         If InStr(k, ":") > 0 Then
    
25.             crr = Split(WorksheetFunction.Clean(k), ":")
    
26.             s = WorksheetFunction.Clean(crr(0))
    
27.             If d.exists(s) Then brr(1, d(s)) = crr(1)
    
28.         End If
    
29.     Next k
    
30.     '将brr中的数据写入到工作表2中，并在最后一行的下一行插入brr的第一行数据
    
31.     brr(1, 1) = UBound(brr)
    
32.     Sheets(2).Cells(UBound(brr) + 1, 1).Resize(1, UBound(brr, 2)) = brr
    
33. End Sub

复制代码

高度保密

你是怎么把发票上的数据整到word文件中的？

高度保密

你是怎么把PDF发票数据整到word文件中的？

武松打鼓

aecn 发表于 2023-6-20 10:20

谢谢帮助。