知识树投稿区

wojoy Lv.1

2020-4-17 17:18 关注
希望论坛大神可以帮忙修改一下提取出来是原表是如框框内这样的打钩
7[R[`XD0D5M3UR9WN@FBPXE.png

提取出来的大部分无论打没打钩都是如图“（”这样的
QMFFYZ7H4UCYSM]_W$}AG2R.png

多日研究终未解决，只有求论坛大神了。。。。

esDoc2Xls.rar   2020-4-17 17:16 上传

文件

544.8 KB, 下载次数: 8

赏
2279阅读
4回复 正序

zmj9151 Lv.3 5楼

2020-4-17 22:22
好象每个文档编码不一样,你试试
image.png

D级-1-SW0136-A006贵州省台江县老屯乡望虎屯村二组杨云生房屋报告.rar   2020-4-17 22:21 上传

162.56 KB, 下载次数: 9

wojoy 楼主 4楼

2020-4-17 20:22
引用: zmj9151 发表于 2020-4-17 18:23
Selection.Find.Text = ChrW(254) 或者是其它值，录宏可见

小白不懂，可否帮我改一下

zmj9151 Lv.3 3楼

2020-4-17 18:23
Selection.Find.Text = ChrW(254) 或者是其它值，录宏可见

wojoy 楼主 2楼

2020-4-17 17:20
  1. Sub 提取word表格1()

  3.     Dim wApp, myfile, t
  4.     mypath = ThisWorkbook.Path & ""
  5.     myname = Dir(mypath & "*.doc")
  6.     m = 1
  7.         Do While myname <> ""
  8.         Set mydoc = GetObject(mypath & myname)
  9.         With mydoc
  10.             m = m + 1
  11.             mydoc.Content.Find.Execute findtext:=ChrW(163), ReplaceWith:="□", Replace:=2
  12.             With .Tables(1)
  13.                 Cells(m, 1) = m - 1
  14.                 Cells(m, 2) = "'" & myname
  15.                 Range("A1:F1") = Array("序号", "文件名", "报告编号", "住址", "A级", "B级")
  16.                 Cells(m, 3) = Replace(.cell(2, 4).Range.Text, "", "")
  17.                 Cells(m, 4) = Replace(.cell(5, 2).Range.Text, "", "")
  18.                 Cells(m, 5) = Replace(.cell(25, 1).Range.Text, "(", "R")
  19.                 Cells(m, 5) = Replace(Cells(m, 5).Text, "", "")
  20.                 Cells(m, 5).Characters(Start:=1, Length:=1).Font.Name = "Wingdings 2"
  21.                 Cells(m, 5).Characters(Start:=2, Length:=30).Font.Name = "宋体"
  22.                 Cells(m, 6) = Replace(.cell(25, 2).Range.Text, "(", "R")
  23.                 Cells(m, 6) = Replace(Cells(m, 6).Text, "", "")
  24.                 Cells(m, 6).Characters(Start:=1, Length:=1).Font.Name = "Wingdings 2"
  25.                 Cells(m, 6).Characters(Start:=2, Length:=30).Font.Name = "宋体"
  26.             End With
  27.             .Close False
  28.         End With
  29.         myname = Dir()
  30.         Loop
  31.         Set mydoc = Nothing
  32.         MsgBox "提取完成"

  34. End Sub

已显示全部内容

高级模式
插入