求助，EXCEL提取WORD中对应的内容

mkpxd

gwjkkkkk 发表于 2024-4-9 18:03
文档总层是指目录总层数吗？

总层数为" & _ "(\d+).   这里不会修改

1013182120

mkpxd 发表于 2024-4-9 17:07
感谢，想再问一下，如果文档总层数为20(含-2)层，要取20(含-2)，代码总层数为" & _
          "(\d+).  ...

" & _
          "(\d+\(含-?\d+\)).   这样成功了

mkpxd

CBWSY 发表于 2024-4-9 17:19
对正则不熟悉的话，也可以按照下面的方法处理，就是速度可能差了点。

感谢帮助，看了一下，是按颜色填入表格对应位置的，我这个颜色标记是方便大家知道需要复制哪些内容的，平时是不标记颜色的

铁马1980

mkpxd 发表于 2024-4-9 19:13
谢谢帮助，你这个我也试了，也是每个单元格的内容前面都带个逗号。

数值前面加个单引号  '  ，是为了把数值型数据转为文本格式，如果没有这个单引号，那你合同号008，存到excel单元格中就变成了8，而不是“008”.写程序的时候，图省事就所有数据都加了，面上看不出来，不影响阅读。如果你这表格数据还要引用加工，可以改一下里面的代码，或者使用时用函数处理一下。

mkpxd

铁马1980 发表于 2024-4-10 09:56
数值前面加个单引号  '  ，是为了把数值型数据转为文本格式，如果没有这个单引号，那你合同号008，存到ex ...

明白了， 我说的呢， 再次感谢！

mkpxd

感谢大家的帮助，最后采用了3楼的方法，圆满解决！谢谢大家！

huarong7984

所发示例，系在2楼代码基础上，稍作修改：去除了数字单元格前的撇号，保留了文本单元格格式输出，美化了表格，仅供参考


Sub TEST()
  Dim str As String, reg As Object, ar()
  Dim wdcx As Object, wd As Object, rg As Range
  Range("A:P").Clear                                                                                                        '清除数据及格式
  Set wdcx = CreateObject("word.application")
  Set reg = CreateObject("Vbscript.Regexp")
  ar = Array("位于(\S+)住宅房地产", "天外", "面积(\d+\.?\d+)平方米", "单价为：(\S+) 元", "价值为：(\S+) 元", _
    "币：([一-龢]+整)", "于(\d+)年", "总层数为(\d+)层", "所在层数为(\d+)层", "估价对象(\S+)估价目的", _
    "价值时点：(\S+)。", "天外", "天外", "]第(\S+)号", "向([一-龢]+)股份")
  str = Dir("" & ThisWorkbook.Path & "\*.doc*")
  k = 0
  mm = Sheet2.Cells(Rows.Count, 2).End(xlUp).Row + 1
  Application.ScreenUpdating = False
  Do While str <> ""
    Text = ""
    Set wd = wdcx.documents.Open(ThisWorkbook.Path & "\" & str)
    wdcx.Visible = True
    x = wd.Paragraphs.Count   '总段落数
    For Each para In wd.Paragraphs
        Text = Text & para.Range.Text
    Next para
    Set rg = Sheet2.Range("a" & mm)
    For i = 0 To UBound(ar)
        k = k + 1
        With reg
            .Global = True
            .Pattern = ar(i)
            If .TEST(Text) Then
                Set m = .Execute(Text)
                s = m.Item(0).submatches(0)
                rg.Offset(0, k) = "" & s                                                                                   '去除了引号中的 ' 撇号，即对应单元格前不带 ' 撇号
                Range("O:O").NumberFormat = "@"                                                                            '设置单元格O列的数据类型为文本
  Else
                rg.Offset(0, k) = "不用管"
            End If
        End With
    Next
    mm = mm + 1
    k = 0
    str = Dir
    Range("B1:P1") = Array("位置", "小区名称", "建筑面积", "单价：元/平米", "抵押价值：元", "人民币大写", _
     "建成日期", "总层数", "所在层数", "估价对象位置", "价值时点", "报告日期", "到期日期", "告知函编号", "申请贷款银行")  '填充列标题
    Range("B1:P1").Interior.Color = RGB(254, 248, 236)                                                                    '单元格B1:P1的背景颜色为浅黄色
    Range("A:P").EntireColumn.AutoFit                                                                                     '自动调整单元格列宽
    Range("A:P").EntireRow.AutoFit                                                                                        '自动调整单元格行高
    Range("A1:P1").HorizontalAlignment = xlCenter                                                                         '设置单元格A1:P1的水平对齐方式为居中
    Range("A1:P1").Font.Bold = True                                                                                       'A1:P1字体为加粗
    [A1].CurrentRegion.Borders.LineStyle = xlContinuous                                                                   '添加边框
    wd.Save
    wd.Close
  Loop
  wdcx.Quit
  Set wdcx = Nothing
  Set wd = Nothing
  Application.ScreenUpdating = True
End Sub

mkpxd

huarong7984 发表于 2024-4-10 12:32
所发示例，系在2楼代码基础上，稍作修改：去除了数字单元格前的撇号，保留了文本单元格格式输出，美化了表 ...

下载了，解压不了呢

huarong7984

mkpxd 发表于 2024-4-10 14:41
下载了，解压不了呢

重新压缩，上传

huarong7984

mkpxd 发表于 2024-4-10 14:41
下载了，解压不了呢

重新压缩上传