求助！ 想把如下整个过程写成一个vba 。excel或者word的都行！请高手帮忙

[qq_37339100]

[dsd999]

有点复杂，会录制宏吗？录制一次操作，然后试着改改 。

[X-i-n]

很简单的需求，但是这个问题价值超过200分

[lt0314]

Sub TableDoc2Xls()
Dim tb As Table, ce As Cell, ro As Row, r As Index, c As Index, dic As Object, ex As Object
Dim tt As String, arr
Set dic = CreateObject("scripting.dictionary")
For Each tb In ThisDocument.Tables
    For Each ro In tb.Rows
        tt = ""
        For Each ce In ro.Cells
            tt = tt & "`" & ce.Range.Text
        Next
        tt = Replace(Mid(tt, 2, 99999), Chr(13) & Chr(7), "")
        dic(tt) = Split(tt, "`")
    Next
Next
arr = dic.items
Set ex = CreateObject("excel.application")
With ex
    .Visible = True
    .workbooks.Add
    .sheets(1).Cells(1, 1).Resize(UBound(arr) + 1, UBound(arr(0)) + 1) = arr2xlarr(arr)
End With
End Sub
Function arr2xlarr(arr)
Dim tarr(), i As Integer, j As Integer, rs As Integer, cs As Integer
rs = UBound(arr) + 1: cs = UBound(arr(0)) + 1
ReDim tarr(rs, cs)
For i = 1 To rs
    For j = 1 To cs
        tarr(i, j) = arr(i - 1)(j - 1)
    Next
Next
arr2xlarr = tarr
End Function