|
Sub 准考证汇总()
Dim wd As Word.Application
Dim odoc As Object
Dim arr(1 To 10000, 1 To 12)
Application.ScreenUpdating = False
t = Timer
Set wd = CreateObject("word.application")
mypath = ThisWorkbook.Path & "\"
fn = Dir(mypath & "*.do*")
Do While fn <> ""
Set odoc = wd.Documents.Open(mypath & fn)
With odoc
For Each tablex In .Tables
If tablex.Rows.Count = 11 And tablex.Columns.Count = 6 Then
Num = Num + 1
With tablex
arr(Num, 1) = .Cell(2, 2).Range
For Each k In Array(3, 4, 5, 6, 7)
arr(Num, k) = .Cell(k, 2).Range
Next
For Each k In Array(9, 10, 11, 12)
arr(Num, k) = .Cell(k - 1, 2).Range
Next
arr(Num, 2) = .Cell(2, 4).Range
arr(Num, 8) = .Cell(7, 4).Range
End With
End If
Next
.Close
End With
fn = Dir()
Loop
wd.Quit
For i = 1 To Num
For j = 1 To UBound(arr, 2)
arr(i, j) = Left(arr(i, j), Len(arr(i, j)) - 1)
Next
Next
Set wd = Nothing
Set odoc = Nothing
Sheets(1).Activate
Rows("2:10000").Clear
Range("a2").Resize(Num, 12) = arr
With Range("a1").CurrentRegion
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Borders.LineStyle = 1
End With
MsgBox Timer - t
Application.ScreenUpdating = True
End Sub
|
|