请大神帮忙指点Excel写入Word文件内容指定值的问题

hnlx1001

需求：各位大神，功能基本己经实现，就差有新的Word文件放入指定路径后，判断重复记录时我设置的条件不能调出本次循环，请大神帮忙指点一下，谢谢！
   写入规则：
     1.根据Excel的A列的序号与Word文件名的序号对应，并且序号所在行的其他需要写入的单元格为空时对应写入Word中的对应的值；
     2.如果序号是非连续的或者序号所在行的其他需要写入的单元格为非空时，要检查是否为重复记录，是重复记录的跳过执行下一条，
     3.内容链接列的内容为Word文件名相对地址超链接，显示内容为Word文件名去扩展名；
     4.点选月份sheet表可写入相应月份文件夹的Word文件相应内容；
     5.有新的系统导出的Word处理表格的放到相应的月份文件夹时，写入新的内容时自动跳过己经写入的记录，只写入新的记录；
      6.其他未想到的请大神帮忙设置，
                                  谢谢！

Word文件内容为系统导出，格式无法改变，“编号：144030000000000000005       紧急程度：一般       日期：2018-01-02 ”这一行不在Word表格内。

Q526753064

需要有些地方详细说下

hnlx1001

各位大神，功能基本己经实现，就差有新的Word文件放入指定路径后，判断重复记录时我设置的条件不能调出本次循环，请大神帮忙指点一下，谢谢！
Sub WordtoExcel()
'Excel 将word表格中数据提取到excel表格中
   ' Dim wordD As Word.Document '定义word类
    Dim wordapp As Object     '定义Word对象
    'Application.ScreenUpdating = False '//关闭屏幕刷新
    t = Timer   '//开始时间
    cPath = ThisWorkbook.Path & "\" & ActiveSheet.Name & "\" & "修改版\" '获取当前Word文件所在文件夹的路径
    cFile = Dir(cPath & "*.doc")  ' /*这里指定了需要打开的文件名*/
    Set wordapp = CreateObject("word.Application")
    Do While cFile <> ""
      'Set wordapp = CreateObject("Word.Application")
      'wordapp.Visible = False
      Set wordD = GetObject(cPath & cFile) '/*这里指定了需要打开哪个文件*/
          xh = Mid(cFile, InStr(1, cFile, "(") + 1, InStr(1, cFile, ")") - InStr(1, cFile, "(") - 1) '取出文件名中的编号
    If [G3] <> "" Then
          r = [G65536].End(xlUp).Row + 1
    Else: r = 3
    End If
          i = [G65536].End(xlUp).Row
         
    If Range("A" & i) = xh And Range("G" & i) <> "" Then
             GoTo LineNext
    Else
        If Range("A" & i) = xh Then
              r = Range("A" & r).Row + 2
        Else
              r = Range("A" & xh).Row + 2
        End If
    End If
             With wordD.Tables(1)
                Range("C" & r).NumberFormatLocal = "@"
                Range("C" & r) = Replace(.Cell(6, 2).Range.Text, vbCr & "", "") '咨询员
                Range("F" & r).NumberFormatLocal = "@"
                Range("F" & r) = Replace(.Cell(2, 2).Range.Text, vbCr & "", "") '信访人
                Range("G" & r).NumberFormatLocal = "0"
                Range("G" & r) = Replace(.Cell(5, 4).Range.Text, vbCr & "", "") '电话号码
                Range("H" & r).NumberFormatLocal = "@"
                Range("H" & r).Select
                ActiveSheet.Hyperlinks.Add anchor:=Selection, Address:=cPath & "\" & cFile, TextToDisplay:=Split(cFile, ".")(0) '添加超链接
             End With
                Range("D" & r).NumberFormatLocal = "@" '来电编号变为文本格式
                Range("D" & r) = Mid(wordD.Paragraphs(wordD.Paragraphs.Count).Range.Text, InStr(1, wordD.Paragraphs(wordD.Paragraphs.Count).Range.Text, "编号") + 5, 22) '来电编号
                Range("B" & r).NumberFormatLocal = "m-d"  '来电日期格式
                Range("B" & r) = Mid(wordD.Paragraphs(wordD.Paragraphs.Count).Range.Text, InStr(1, wordD.Paragraphs(wordD.Paragraphs.Count).Range.Text, "日期") + 5, 10) '来电日期
        wordD.Close
LineNext:
        cFile = Dir()
    Loop
    Set wordD = Nothing
    'wordapp.Visible = True
    'wordapp.Quit
    'Application.ScreenUpdating = True '//恢复屏幕刷新
MsgBox "一共用时：" & Format(Timer - t, "#0.0000") & " 秒", , "系统提示!!"  '//提示所用时间
End Sub