各位大师，帮忙修改下代码

冷酷的云 · 发表于 2020-7-7 22:22

SUB CC()
Application.DisplayAlerts = False: Application.ScreenUpdating = False
Dim wd, mp$, mf$, doc, r, a, b
Set wd = CreateObject("word.Application") '定义Word对象
Sheet1.[a2:b60000].ClearContents
mp = ThisWorkbook.Path & "\"
mf = Dir(mp & "*.doc*")
Do While mf <> ""
      Set doc = wd.Documents.Open(mp & mf) '后台打开Word文档
      a = Replace(Replace(Trim(Split(wd.Selection.Document.Paragraphs(4).Range.Text, "：")(1)), Chr(13), ""), " ", "")
      b = Application.Clean(Trim(Split(doc.Tables(2).Cell(4, 4).Range.Text, "：")(1)))
      doc.Close False '关闭word
      With Sheets("sheet1")
         r = .Cells(Rows.Count, 1).End(3).Row + 1
         .Cells(r, 1) = a: Cells(r, 2) = b
      End With
      mf = Dir '显示下一个word文档
Loop
wd.Quit
Application.DisplayAlerts = True: Application.ScreenUpdating = True
MsgBox "OK，完成！！！", 48, "温馨提示……"
End Sub
  b = Application.Clean(Trim(Split(doc.Tables(2).Cell(4, 4).Range.Text, "：")(1)))
把这个代码修改成查找定位，查找定位签发日期并复制日期放在电子表格B列最后一个单元，谢谢！

测试1 (1).zip (47.62 KB, 下载次数: 15)

gbgbxgb · 发表于 2020-7-26 06:43

连签发日期和报告日期都没搞清，就发帖求助？

冷酷的云 · 发表于 2020-7-29 07:51

已经解决

		自动登录	找回密码
密码			免费注册