20170907wdVBA_GetCellsContentToExcel

 'WORD 加载项 代码模板
Dim cmdBar As CommandBar, cmdBtn As CommandBarControl
Const cmdBtnCap As String = "批量提取操作步骤"

Sub AutoExec()

    Call DelCmdBtn
    Call AddCmdBtn

End Sub
Sub AutoExit()
    Call DelCmdBtn
End Sub

Sub AddCmdBtn()

    Set cmdBar = Application.CommandBars("Tools")

    Set cmdBtn = cmdBar.Controls.Add(msoControlButton)
    With cmdBtn
        .Caption = cmdBtnCap
        .Style = msoButtonCaption
        .OnAction = "GetContents"
    End With

    Set cmdBtn = Nothing
    Set cmdBar = Nothing

End Sub
Sub DelCmdBtn()
    Set cmdBar = Application.CommandBars("Tools")
    For Each cmdBtn In cmdBar.Controls
        If cmdBtn.Caption = cmdBtnCap Then cmdBtn.Delete
    Next

    Set cmdBtn = Nothing
    Set cmdBar = Nothing
End Sub

Public Sub GetContents()

    Application.ScreenUpdating = False

    Dim xlApp As Object
    Dim Wb As Object
    Dim Sht As Object
    Dim Rng As Object
    Dim OpenDoc As Document

    Dim ExcelPath As String
    Const ExcelFile As String = "未完成.xls"

    Dim FolderPath As String
    Dim FilePath As String
    Dim FileName As String

    ExcelPath = ThisDocument.Path & "\" & ExcelFile

   With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisDocument.Path
        .AllowMultiSelect = False
        .Title = "请选取Word所在文件夹"
        If .Show = -1 Then
            FolderPath = .SelectedItems(1)
        Else
            MsgBox "您没有选中任何文件夹，本次汇总中断！"
            Exit Sub
        End If
    End With

    s = Split(FolderPath, "\")
    c = UBound(s)
    ShtName = s(c)

    If Right(FolderPath, 1) <> "\" Then FolderPath = FolderPath & "\"

    On Error Resume Next
        Set xlApp = GetObject(, "Excel.Application")
        If xlApp Is Nothing Then
            Set xlApp = CreateObject("Excel.Application")
        End If
    On Error GoTo 0

    Set Wb = xlApp.workbooks.Open(ExcelPath)
 Set Sht = Wb.worksheets.Add()
 Sht.Name = ShtName
                Sht.Cells.clearcontents
                Sht.Range("A1:D1").Value = Array("操作编号", "操作任务", "操作序号", "操作步骤")

    FileName = Dir(FolderPath & "*.doc*")
    Do While FileName <> ""
        FilePath = FolderPath & FileName
        If FileName <> ThisDocument.Name Then
            Set OpenDoc = Application.Documents.Open(FilePath)
            'If OpenDoc.Tables.Count > 0 Then
                Arr = GetArray(OpenDoc)

               Debug.Print Arr(3, 1)

                Sht.Cells(Sht.Rows.Count, 2).End(3).offset(1).Resize(UBound(Arr, 2), UBound(Arr)).Value = _
                xlApp.worksheetfunction.transpose(Arr)

            'End If
            OpenDoc.Close False
        End If
        FileName = Dir
    Loop

    Wb.Close True
    xlApp.Quit

    'MsgBox "本次提取完成！"

    'Application.ScreenUpdating = True
End Sub

Function GetArray(ByVal Doc As Document) As Variant
    Dim tb As Table
    Dim tbCount As Long
    Dim RecordStart As Boolean
    Dim RecordEnd As Boolean
    Dim Arr() As String
    Dim Mission As String

    Doc.Activate
        If Selection.Type = wdSelectionIP Then
        ActiveDocument.Content.ListFormat.ConvertNumbersToText
        ActiveDocument.Content.Find.Execute FindText:="^t", replacewith:=" ", Replace:=wdReplaceAll
    Else
        Selection.Range.ListFormat.ConvertNumbersToText
        Selection.Find.Execute FindText:="^t", replacewith:=" ", Replace:=wdReplaceAll
    End If

    ReDim Arr(1 To 3, 1 To 1)
    Index = 0

    RecordStart = False
    RecordEnd = False

    tbCount = Doc.Tables.Count
    If tbCount > 0 Then
        n = 0
        For Each tb In Doc.Tables

            With tb
                For i = 1 To .Rows.Count
                'Debug.Print tb.Rows(3).Cells(1).Range.Text
               If tb.Rows(3).Cells(1).Range.Text Like "*操作任务*" And Mission = "" Then
                                Mission = tb.Rows(3).Cells(1).Range.Text
                                Mission = RegGet(Mission, "操作任务[：:](\S+?)\s+?")
                                'Debug.Print Mission
                End If

                    If .Rows(i).Cells.Count = 5 Then
                        If .Rows(i).Cells(1).Range.Text Like "*#*" And _
                            .Rows(i).Cells(3).Range.Text Like "*得令*" Then
                            'Debug.Print .Rows(i).Cells(3).Range.Text
                            RecordStart = True
                        End If
                       If .Rows(i).Cells(1).Range.Text Like "*#*" Or .Rows(i).Cells(1).Range.Text = "" And RecordStart = True And RecordEnd = False Then
                            Index = Index + 1
                            ReDim Preserve Arr(1 To 3, 1 To Index)
                         Arr(1, Index) = Mission
                         Debug.Print Mission
                         Arr(2, Index) = Replace(Replace(.Rows(i).Cells(1).Range.Text, Chr(7), ""), vbCr, "")
                         Arr(3, Index) = Replace(Replace(.Rows(i).Cells(3).Range.Text, Chr(7), ""), vbCr, "")
                       End If

                        If .Rows(i).Cells(1).Range.Text Like "*#*" And _
                            .Rows(i).Cells(3).Range.Text Like "*汇报*" Then
                            RecordStart = False
                            RecordEnd = True
                            GoTo ExitFunction
                        End If
                    End If
                Next i
            End With
        Next tb
    End If

ExitFunction:
 GetArray = Arr

End Function
Public Function RegGet(ByVal OrgText As String, ByVal Pattern As String) As String
'传递参数 ：原字符串， 匹配模式
    Dim Regex As Object
    Dim Mh As Object
    Set Regex = CreateObject("VBScript.RegExp")
    With Regex
        .Global = True
        .Pattern = Pattern
    End With
    If Regex.test(OrgText) Then
        Set Mh = Regex.Execute(OrgText)
        RegGet = Mh.Item(0).submatches(0)
    Else
        RegGet = ""
    End If
    Set Regex = Nothing
End Function
Sub 自动编号转文本()
    If Selection.Type = wdSelectionIP Then
        ActiveDocument.Content.ListFormat.ConvertNumbersToText
        ActiveDocument.Content.Find.Execute FindText:="^t", replacewith:=" ", Replace:=wdReplaceAll
    Else
        Selection.Range.ListFormat.ConvertNumbersToText
        Selection.Find.Execute FindText:="^t", replacewith:=" ", Replace:=wdReplaceAll
    End If
End Sub