VBA读取word文档表格中table的cell的text文本

Sub Readtable()

Dim filename As String Dim filenum As Long Dim fileslist As String Dim outfile As String Dim outfile_log As String

outfile = \"I:综合整理结果20100525-2其它各省1257省集合_125.txt\"

fileslist = \"I:综合整理结果20100525-2其它各省125Filellist_125.txt\" '输⼊读取的word⽂件列表 outfile_log = \"I:综合整理结果20100525-2其它各省1257省集合_125_log.txt\" filenum = 125 '输⼊读取的word⽂件列表中的⽂件数 Open fileslist For Input As #1 Open outfile For Output As #2 Open outfile_log For Output As #3

Dim wdApp As Word.Application, wdDoc As Word.Document On Error Resume Next

Set wdApp = GetObject(, \"Word.Application\")

If Err.Number <> 0 Then 'Word isn't already running Set wdApp = CreateObject(\"Word.Application\") End If

On Error GoTo 0

Dim tableNum As Long

Dim i As Long, j As Long, k As Long, m As Long, n As Long Dim r1 As Long, r7 As Long, r4 As Long Dim result As String

Dim temp As String, temp00 As String, temp0 As String, temp1 As String, temp2 As String Dim oCel As Cell Dim flag As Long For i = 1 To filenum

Line Input #1, filename

Set wdDoc = wdApp.Documents.Open(filename) wdApp.Visible = True

'WrdApp.Documents.Open filename:=myFilename 'wdDoc.PrintOut

'wdDoc.SaveAs \"C:temphello.doc\" wdDoc.Activate

tableNum = ActiveDocument.Tables.Count Print #3, filename, \"#\ result = \"\"

Set oCel = Nothing For j = 1 To tableNum

'Set oTable = ActiveDocument.Tables(j) 'Dim oCel0 As Cell 'Dim oCel1 As Cell 'Dim oCel2 As Cell 'Obtain location cells

Set oCel = ActiveDocument.Tables(j).Cell(2, 2) temp = Mid(oCel.Range.Text, 1, 1) '当cell(2,2)为“地”时 r7 = 7 r4 = 4 r1 = 2 flag = 0

'当cell(2,2)为\"调\"时 If temp = \"调\" Then r7 = r7 - 1 r4 = r4 - 1 r1 = r1 - 1 flag = -1 End If

If temp = \"因\" Then r7 = r7 + 1 r4 = r4 + 1 r1 = r1 + 1 flag = 1 End If

'读取记录表类型 temp00 = \"\"

Set oCel = ActiveDocument.Tables(j).Cell(r7, 2)

'oCel.Range.MoveEnd Unit:=wdCharacter, Count:=-1 temp00 = Replace(oCel.Range.Text, Chr(13), \ '************************************************************** '读取地点，调查时间 temp0 = \"\"

For k = r1 To 1 + r1

Set oCel = ActiveDocument.Tables(j).Cell(k, 3)

'oCel.Range.MoveEnd Unit:=wdCharacter, Count:=-1

temp0 = temp0 + \"#\" + Replace(oCel.Range.Text, Chr(13), \ Next k

'3 地理坐标 X：0628489 Y：4190334 temp1 = \"\" For m = 1 To 4

Set oCel = ActiveDocument.Tables(j).Cell(r4, m)

'oCel.Range.MoveEnd Unit:=wdCharacter, Count:=-1

temp1 = temp1 + \"#\" + Replace(oCel.Range.Text, Chr(13), \ Next m

'Set oCel0 = ActiveDocument.Tables(j).Cell(4, 1) 'Set oCel1 = ActiveDocument.Tables(j).Cell(4, 3) 'Set oCel2 = ActiveDocument.Tables(j).Cell(4, 4) 'Obtain 轨道号

'成像时间,沙化类型 , 沙化程度, ⼟地利⽤类型, 主要植物种, 主要植被盖度, 植被总盖度, '植被长势, ⼟壤类型, ⼟壤质地, 治理措施, 影像⾊彩, 影像纹理, 分布状况, ⽐例尺 temp2 = \"\"

For n = 5 + flag To 10 + flag

Set oCel = ActiveDocument.Tables(j).Cell(n, 3)

'oCel.Range.MoveEnd Unit:=wdCharacter, Count:=-1

temp2 = temp2 + \"#\" + Replace(oCel.Range.Text, Chr(13), \ Next n

'Set oCel4 = ActiveDocument.Tables(j).Cell(6, 3) 'Set oCel5 = ActiveDocument.Tables(j).Cell(5, 3)

'For Each aCell In oTable.Rows(4).Cells(1 - 4) '设定读取的表⾏

'Set myRange = ActiveDocument.Range(Start:=aCell.Range.Start, End:=aCell.Range.End - 1) 'MsgBox myRange.Text

'Set myRange = aCell.Range

'myRange.MoveEnd Unit:=wdCharacter, Count:=-1 ' ⾮常重要,⽬的是去掉换⾏符' 否则内容后⾯会有个⼩圆点 'MsgBox myRange.Text

'‘temp = Concat(\

result = temp00 + temp0 + temp1 + temp2 'Next aCell

Print #2, CStr(i), \"*\ Next j

wdDoc.Close Next i Close #1 Close #2 Close #3