VBA多个WORD文档表格数据写入到EXCEL中

工作提示：

1、当前目录下有多个相同的WORD表格；

2、在EXCEL中新建VBA项目；

3、将WORD表格中的数据读取写入到一条EXCEL记录中去。

'目录下多个WORD表格批量处理

Sub ReadMoreWords2MyExcel()

   Set Exlapp = CreateObject("excel.Application")
   
   Dim MyDoc As Object
   
   Dim MyPath$, MyName$, str$, m%, t$
   
   Dim Brr(1 To 1000, 1 To 66)
   
   Dim iCount As Integer, iii As Integer, kk As Integer, ii As Integer, col As Integer, tt As String, u As String, stxt As String
   
   Dim xCount As Integer
   
   MyPath = ThisWorkbook.Path & "\"
   MyName = Dir(MyPath & "*.doc?")
   m = 0

  
   Do While MyName <> "" '遍历WORD文档
      Set MyDoc = GetObject(MyPath & MyName) '打开WORD文档
     With MyDoc
       m = m + 1 '记录数据条数
       
       With .tables(1)
       
        Brr(m, 1) = m ''将序号数据存入当前工作表的A列4行单位格
        Brr(m, 2) = Application.Clean(.Cell(1, 2).Range) '姓名将word表格第1行第2列姓名的数据存入当前工作表的B列
        Brr(m, 3) = Application.Clean(.Cell(1, 4).Range) '性别将word表格第1行第4列性别的数据存入当前工作表的C列
        Brr(m, 4) = "'" + Application.Clean(.Cell(1, 6).Range) '出生年月将word表格第1行第6列民族的数据存入当前工作表的D列
        
        Brr(m, 5) = Application.Clean(.Cell(2, 2).Range) '民族
        Brr(m, 6) = Application.Clean(.Cell(2, 4).Range) '籍贯
        Brr(m, 7) = Application.Clean(.Cell(2, 6).Range) '党派
        
        Brr(m, 8) = Application.Clean(.Cell(3, 2).Range) '是否有国（境）外永久居留
        Brr(m, 9) = Application.Clean(.Cell(3, 4).Range) '所在代表团
        
        Brr(m, 10) = Application.Clean(.Cell(4, 2).Range) '提名方式
        Brr(m, 11) = Application.Clean(.Cell(4, 4).Range) '健康状况
        Brr(m, 12) = "'" + Application.Clean(.Cell(4, 6).Range) '参加工作时间

        Brr(m, 13) = Application.Clean(.Cell(5, 2).Range) '职称
        Brr(m, 14) = Application.Clean(.Cell(5, 4).Range) '学历学位
        Brr(m, 15) = Application.Clean(.Cell(5, 6).Range) '所学专业
        Brr(m, 16) = Application.Clean(.Cell(5, 8).Range) '个人特长
        
        Brr(m, 17) = Application.Clean(.Cell(6, 2).Range) '毕业院校
        Brr(m, 18) = "'" + Application.Clean(.Cell(6, 4).Range) '身份证号码

        Brr(m, 19) = Application.Clean(.Cell(7, 2).Range) '所属结构
        
        Brr(m, 20) = Application.Clean(.Cell(8, 2).Range) '电子信箱
        Brr(m, 21) = Application.Clean(.Cell(8, 4).Range) '微信号
        
        Brr(m, 22) = Application.Clean(.Cell(9, 2).Range) '通讯地址
        Brr(m, 23) = Application.Clean(.Cell(9, 4).Range) '手机
        
        Brr(m, 24) = Application.Clean(.Cell(10, 2).Range) '邮编
        Brr(m, 25) = Application.Clean(.Cell(10, 4).Range) '传真
        Brr(m, 26) = Application.Clean(.Cell(10, 6).Range) '办公电话
        
        Brr(m, 27) = Application.Clean(.Cell(11, 2).Range) '工作单位及现任（或原任）职务
        
        Brr(m, 28) = Application.Clean(.Cell(12, 2).Range) '简历
        
        Brr(m, 29) = Application.Clean(.Cell(13, 2).Range) '主要表现
        Brr(m, 30) = Application.Clean(.Cell(14, 2).Range) '选举结果
        
        'Brr(m, 33)16行为家庭主要成员开始项
        
        Brr(m, 31) = Application.Clean(.Cell(22, 2).Range) '现任或历任职务情况（地方、届次、任期起止时间）
        Brr(m, 32) = Application.Clean(.Cell(23, 2).Range) '备注
        

        

'-------------为家庭主要成员数据项--------------

kk = 1 '亲属数据表格起始行数

ii = 16 '亲属数据从第16行开始

iii = 5 '亲属数据总行数5

col = 33 '亲属数据开始写入的列数

tt = ""

Do While ii <= 20

     
     If kk <= 5 Then '判断当前行数
     
     
     stxt = Trim(Application.Clean(.Cell(ii, 2).Range))
     If stxt <> "" Then
     tt = tt + stxt + "，"
     Brr(m, col) = stxt '称谓
     End If
     
     stxt = Trim(Application.Clean(.Cell(ii, 3).Range))
     If stxt <> "" Then
     tt = tt + stxt + "，"
     Brr(m, col + 1) = stxt '姓名
     End If
     
     stxt = Trim(Application.Clean(.Cell(ii, 4).Range))
     If stxt <> "" Then
     tt = tt + stxt + "，"
     Brr(m, col + 2) = stxt '出生年月
     End If
     
     stxt = Trim(Application.Clean(.Cell(ii, 5).Range))
     If stxt <> "" Then
     tt = tt + stxt + "，"
     Brr(m, col + 3) = stxt '政治面貌
     End If

     stxt = Trim(Application.Clean(.Cell(ii, 6).Range))
     If stxt <> "" Then
     tt = tt + stxt + "，"
     Brr(m, col + 4) = stxt '单位职务
     End If

     stxt = Trim(Application.Clean(.Cell(ii, 7).Range))
     If stxt <> "" Then
     tt = tt + stxt + "；"
     Brr(m, col + 5) = stxt '是否外国国籍或者获得国（境）外永久居留资格、长期居留许可
     End If
     
     col = col + 5
     
     End If
     
     col = col + 1
     
     ii = ii + 1

     kk = kk + 1
     
     Loop
        

'-------------为家庭主要成员数据项--------------

       End With
        .Close False '关闭WORD文档
     End With
     MyName = Dir() '下一个WORD文档
     
   Set MyDoc = Nothing '释放对象变量
   
   Loop
   

   Set Exlapp = Nothing '释放对象变量
   
   '输出数据
   
   If m <> 0 Then _
  Worksheets("Sheet1").Range("A5").Resize(m, UBound(Brr, 2)) = Brr 'Sheet1 A列4行单位格开始写入数据
  
  
 End Sub