|
- Sub Macro1()
- On Error Resume Next
- Dim mypath$, wj$, s%, wd
- Application.ScreenUpdating = False
- Range("a2:h2000").ClearContents
- Set wd = CreateObject("word.Application")
- mypath = ThisWorkbook.Path & "\报名表"
- wj = Dir(mypath & "*.doc")
- s = 1
- Do While wj <> ""
- s = s + 1
- With wd.Documents.Open(mypath & wj)
- Cells(s, 1) = .Tables(1).Cell(1, 2).Range
- Cells(s, 2) = .Tables(1).Cell(1, 4).Range
- Cells(s, 3) = .Tables(1).Cell(1, 6).Range
- Cells(s, 4) = .Tables(1).Cell(2, 2).Range
- Cells(s, 5) = .Tables(1).Cell(2, 4).Range
- Cells(s, 6) = .Tables(1).Cell(3, 2).Range
- Cells(s, 7) = .Tables(1).Cell(3, 4).Range
- Cells(s, 8) = .Tables(1).Cell(4, 2).Range
- .Close False
- End With
- wj = Dir
- Loop
- wd.Quit
- ActiveSheet.UsedRange.Replace "", ""
- Application.ScreenUpdating = True
- End Sub
复制代码 |
|