从word文档提取内容并将文件保存到其他目录问题

lxbx

需求说明：                                                
          1、我根据网上查询自己做了按钮（为民热线），目的是读取当前目录下所有word文档（不包括该文件夹的下级目录），提取word文档指定栏目内容到当前工作表指定单元格；                                                
    2、现在无法提取word文档大题目下  编号：后面的内容（word文档里我已经标红了），这个内容提取到当前excel工作表C栏（编号）栏，麻烦帮助解决；                                                
          3、当前文件夹下有四个文件夹，是因为这些来件有四种渠道，我现在想先解决为民热线这一个渠道的文件，在点击上面为民热线按钮实现提取数据后，能将当前文件夹下提取数据的word文档自动剪切到为民热线文件夹下（剪切到为民热线文件夹后，当前目录下不保留这些word文件）；                                                
           4、在提取数据时，能自动在序号栏添加序号，并且在有新数据提取的时候不覆盖原来的记录，在原最后行后面添加，序列号自动添加。因为每天都会有好多来件，这个表就是个登记台账        


具体操作麻烦老师帮助看看附件，感谢！          下面是我照网上老师做的程序自己修改了一下，但满足不了上面说的要求
Option Explicit

Sub main()
    Dim doc As Object
    Dim p As String, f As String
    Dim i As Integer
    Dim arr(1 To 9999, 1 To 12) As String

    Application.ScreenUpdating = False


    p = ThisWorkbook.Path & "\"
    f = Dir(p & "*.doc*")
    '查找每个doc
    Do While f <> ""
        i = i + 1
        Set doc = GetObject(p & f)
        '对文档中第一个表格
        With doc.Tables(1)
            arr(i, 5) = Left(.cell(2, 8), Len(.cell(2, 8)) - 1)
            arr(i, 10) = Left(.cell(2, 2), Len(.cell(2, 2)) - 1)
            arr(i, 3) = Left(.cell(2, 3), Len(.cell(2, 3)) - 1)
          arr(i, 8) = Left(.cell(2, 4), Len(.cell(2, 4)) - 1)
          arr(i, 9) = Left(.cell(2, 5), Len(.cell(2, 5)) - 1)

        End With
        f = Dir()
    Loop
    [a2].Resize(i, 12) = arr
End Sub

'判断
Function pd(Str As String) As String
    With CreateObject("vbscript.regexp")
        .Global = True
        .MultiLine = True
        .Pattern = "(\d+\.){3}\d+"
        If .Execute(Str).Count > 1 Then
            pd = .Execute(Str)(0) & "/" & .Execute(Str)(1)
        End If
    End With
End Function

lxbx

哪位老师帮我修正一下吧，谢谢

爱疯

        Set doc = GetObject(p & f)
        arr(i, 3) = VBA.Replace(doc.Paragraphs(2).Range.Text, "编号：", "")
        '对文档中第一个表格






我WORD不大会，好像能解决第2点。

lxbx

谢谢了