是所有的merge开头的都没有了。
Sub wdtableinserhtmltag()
Dim xlapp As Object
Dim cr As Range, d As Object, c As Byte, r As Integer, s1 As String, s2 As String
On Error Resume Next
With ActiveDocument.Tables(1)
.Range.Select
Selection.Copy
Set xlapp = CreateObject("Excel.Application")
With xlapp
.Visible = True
.ScreenUpdating = False
.DisplayAlerts = False
.Workbooks.Add
.Cells(2).Select
With .ActiveSheet
.Paste
Set cr = .usedRange
If cr.MergeCells Then
For r = 1 To cr.Rows.Count
For c = 2 To cr.Columns.Count + 1
If c = 2 Then
s1 = "<tr><td>" & .Cells(r, 2) & "</td>"
Else
s1 = s1 & "<td>" & .Cells(r, c) & "</td>"
End If
Next
s2 = s2 & s1 & "</tr>"
Next
s2 = "<table>" & s2 & "</table>"
Else
Set cr = .Cells(1).Resize(.usedRange.Rows.Count, .usedRange.Columns.Count + 1)
Set d = CreateObject("scripting.dictionary")
For r = 1 To cr.Rows.Count
For c = 1 To cr.Columns.Count
If c = 1 Then
s1 = "<tr><td></td>"
Else
If .Cells(r, c).MergeCells = False Then
s1 = s1 & "<td>" & .Cells(r, c) & "</td>"
Else
With .Cells(r, c).MergeArea
If d.Exists(.Address) = False Then
s1 = s1 & "<td" & IIf(.Rows.Count = 1, "", " rowspan=" & .Rows.Count) & IIf(.Columns.Count = 1, "", " colspan=" & .Columns.Count) & ">" & Cells(r, c) & "</td>"
d.Add .Address, Nothing
End If
End With
End If
End If
Next
s2 = s2 & s1 & "</tr>"
Next
s2 = "<table>" & Replace(s2, "<tr><td></td>", "<tr>") & "</table>"
End If
End With
.ActiveWorkbook.Close savechanges:=False
.DisplayAlerts = True
.ScreenUpdating = True
.Visible = False
.Quit
End With
Set xlapp = Nothing
MsgBox s2
ActiveDocument.Range(Start:=.Range.End, End:=.Range.End).InsertAfter s2 & vbCrLf
.Delete
End With
End Sub
