Sub test()
Dim p As String, f As String
Dim A(1 To 1000, 1 To 35) As String
Dim i As Integer
Application.ScreenUpdating = False
p = ThisWorkbook.Path & "\个人信息表\"
f = Dir(p & "*.doc*")
Do While f <> ""
With GetObject(p & f).Tables(1)
i = i + 1
A(i, 1) = .cell(1, 1) '不清楚对应关系
A(i, 2) = .cell(2, 2) '姓名
A(i, 3) = .cell(2, 4) '性别
A(i, 4) = .cell(2, 6) '出生日期
A(i, 5) = .cell(3, 2) '出生地
A(i, 6) = .cell(3, 4) '民族
A(i, 7) = .cell(3, 6) '政治面貌
A(i, 8) = .cell(4, 2) '户籍所在地
A(i, 9) = .cell(4, 4) '入党团日期
A(i, 10) = .cell(1, 1)
A(i, 11) = .cell(1, 1)
A(i, 12) = .cell(1, 1)
A(i, 13) = .cell(1, 1)
A(i, 14) = .cell(1, 1)
A(i, 15) = .cell(1, 1)
A(i, 16) = .cell(1, 1)
A(i, 17) = .cell(1, 1)
A(i, 18) = .cell(1, 1)
A(i, 19) = .cell(1, 1)
A(i, 20) = .cell(1, 1)
A(i, 21) = .cell(1, 1)
A(i, 22) = .cell(1, 1)
A(i, 23) = .cell(1, 1)
A(i, 24) = .cell(1, 1)
A(i, 25) = .cell(1, 1)
A(i, 26) = .cell(1, 1)
A(i, 27) = .cell(1, 1)
A(i, 28) = .cell(1, 1)
A(i, 29) = .cell(1, 1)
A(i, 30) = .cell(1, 1)
A(i, 31) = .cell(1, 1)
A(i, 32) = .cell(1, 1)
A(i, 33) = .cell(1, 1)
A(i, 34) = .cell(1, 1)
A(i, 35) = .cell(1, 1)
End With
f = Dir()
Loop
Range("A1").CurrentRegion.Offset(1, 0).ClearContents
Range("j:j").NumberFormat = "@" '因为是身份证信息
[A2].Resize(i, UBound(A, 2)) = A
Range("A1").CurrentRegion.Replace Chr(7), ""
End Sub
蓝色部分的.cells(1,1),请自行修改
方法:数一数WORD表行的几行几列
比如:入党团日期在EXCEL中是第9列,在WORD中是4行4列,所以改成 A(i, 9) = .cell(4, 4)