各位大佬帮忙修改下谢谢

kongkong111

Sub 按钮1_Click()
Set wdcx = CreateObject("Word.Application")
wddz = Dir(ThisWorkbook.Path & "\*.docx")
Cells(2, 1) = "姓名" '
Cells(2, 2) = "性别"
Cells(2, 3) = "年龄"
Cells(2, 4) = "学习科目" '
Cells(2, 5) = "家庭联系人1"
Cells(2, 6) = "关系"
Cells(2, 7) = "电话"
Cells(2, 8) = "家庭联系人"
Cells(2, 9) = "关系"
Cells(2, 10) = "电话"
Range("A2:J2").Interior.Color = vbGreen
T = 3
Do While wddz <> ""
Set wdwd = wdcx.Documents.Open(ThisWorkbook.Path & "\" & wddz)
N = wdcx.ActiveDocument.Tables.Count
For i = 1 To N
With wdcx.ActiveDocument.Tables(i)
Cells(T, 1) = Left(.cell(1, 1), Len(.cell(1, 1)) - 2)
Cells(T, 2) = Left(.cell(1, 2), Len(.cell(1, 2)) - 2)
Cells(T, 3) = Left(.cell(2, 2), Len(.cell(2, 2)) - 2)
Cells(T, 4) = Left(.cell(3, 2), Len(.cell(3, 2)) - 2)
Cells(T, 5) = Left(.cell(4, 2), Len(.cell(4, 2)) - 2)
Cells(T, 6) = Left(.cell(5, 2), Len(.cell(5, 2)) - 2)
Cells(T, 7) = Left(.cell(6, 2), Len(.cell(6, 2)) - 2)
Cells(T, 8) = Left(.cell(11, 2), Len(.cell(11, 2)) - 2)
Cells(T, 9) = Left(.cell(12, 2), Len(.cell(12, 2)) - 2)
Cells(T, 10) = Left(.cell(13, 2), Len(.cell(13, 2)) - 2)
T = T + 1
End With
Next i
wddz = Dir
Loop
wdcx.Quit
Set wdcx = Nothing

MsgBox "完成！"

End Sub
Sub 按钮2_Click()
Range("A2:BQ20000").Clear '清空A2:BQ20000单元格
End Sub

请各位大佬帮忙看看修改下能不能把在当前路径下搜索扩展名为docx的文档改为可以手动选择，并且选择后只读取选择的文件不读取同路径下的其他word文件，还有电话这里有逗号的话能不能提取时候将有多个号码的根据逗号拆分为一个号码一个单元格？

洋务德雷

1. Public Function OpenExcelFiles(m As Integer) As Variant
   
2.       Dim f
   
3.       
   
4. '      ChDir "E:"
   
5. '      ChDir Application.Path
   
6.       f = Application.GetOpenFilename("PDF文件,*.pdf,Word文件,*.docx, Excel文件,*.xlsx,Excel文件,*.xls,Word文件,*.doc", m, "选择要提取信息的文件", , True)
   
7.       OpenExcelFiles = f
   
8. End Function

复制代码

3190496160

如果只是  只读取选择的文件不读取同路径下的其他word文件，好办，2楼代码就行了，但是，还得调整电话，你就得上传你的相应的附件才行