从word向Excel写数据

Sub word_to_excel()
  Dim arr()
  Set Excel对象 = CreateObject("Excel.Application")   '创建Excel应用
  Set 表格 = Excel对象.workbooks.Open("c:\孙兴华.xlsx")  '打开Excel表格

  For Each 单元格 In ActiveDocument.Tables(1).Columns(2).Cells  '遍历word文档表格第2列的每个单元格
    性别 = Split(单元格.Range, Chr(13))(0)
    If 性别 = "男" Then 
      i = i + 1
      ReDim Preserve arr(1 To i)
      arr(i) = Split(单元格.Row.Range, Chr(13) & Chr(7))   '如果这个单元格（word表格中）性别为男，就将所在行的数据，以数组的形式存入arr数组
    End If
  Next

  For Each 值 In arr 
    j = j + 1
    表格.sheets("Sheet1").Range("A1")(j, 1).Resize(1, 3) = 值   '将上面arr数组的数据遍历出来（元素也是数组），赋值给Excel表格
  Next

  表格.Close 1   '关闭Excel表格
End Sub