我在下面遇到了同样的问题：
HTML Text with tags to formatted text in an Excel cell
我输入的代码作为给定答案：
Sub Sample()
Dim Ie As Object
Set Ie = CreateObject("InternetExplorer.Application")
With Ie
.Visible = False
.Navigate "about:blank"
.document.body.InnerHTML = Sheets("Sheet1").Range("A1").Value
.document.body.createtextrange.execCommand "Copy"
ActiveSheet.Paste Destination:=Sheets("Sheet1").Range("A1")
.Quit
End With
End Sub
但我收到了这条消息：
“运行时错误'438'：
对象不支持此属性方法“
我很擅长在Excel上使用VBA而且我不知道该怎么做
我感谢任何帮助
答案 0 :(得分：1)
Sub EXCEL_TO_HTML_RANGE()
Dim path As String
Dim rng As Range
path = Application.ActiveWorkbook.path & "\Book1.htm"
Set rng = Range(Cells(1, 1), Cells(10, 3))
With ActiveWorkbook.PublishObjects.Add(xlSourceRange, path, "Sheet1", _
rng.Address, xlHtmlStatic, "Name_Of_DIV", "Title_of_Page")
.Publish (True)
.AutoRepublish = False
End With
End Sub
或
Sub EXCEL_TO_HTML_WORKBOOK()
Dim path As String
path = Application.ActiveWorkbook.path & "\Book1.htm"
ActiveWorkbook.SaveAs Filename:=path, FileFormat:=xlHtml
End Sub
或者您可以使用此宏
Public Sub RangeToHTM(MyRange, DocDestination, sCaller)
' This macro converts an Excel range to a HTML Table.
'
' Copywrite 1996 - 2011 by Charles Balch, mailto:charlie@balch.edu
' Original Source is at http://balch.org/charlie/hdoc/exceltohtml.html
' MyRange is an Excel range you wish to convert.
' DocDestination is the FileName and Path to send the document to.
'
Dim lRGB As Long
Dim strTitle, MV, CellV, CellA, BGC, Red, Green, Blue, SFC1, strComment, sTable As String
Dim RowStart, Row, RowCount, RowEnd, ColStart, Col, ColCount, ColEnd, Hza, ColSpan, iFreeFile As Integer
Dim SameTitle, blnIFrame, blnBoilerPlate As Boolean
Dim fso As FileSystemObject
Dim fPage As TextStream
If InStr(DocDestination, "iFrame_") Then blnIFrame = True 'The result will be optimized to use as an iFrame
If InStr(DocDestination, "bp_") Then blnBoilerPlate = True 'The result will be optimized to for inserting into other HTML documents
RowStart = Range(MyRange).Row
ColStart = Range(MyRange).Column
ColCount = Range(MyRange).Columns.Count
RowCount = Range(MyRange).Rows.Count
RowEnd = RowStart + RowCount - 1
ColEnd = ColStart + ColCount - 1
If Len(Dir(DocDestination)) > 1 Then Kill DocDestination
Set fso = New FileSystemObject
Set fPage = fso.CreateTextFile(DocDestination, True, True)
If blnBoilerPlate Then 'Skip header if boilerplate
sTable = "<table bgcolor=""#FFFFFF"" border=""1"" align=""center"" >"
fPage.WriteLine "<!-- Begin Boilerplate " & strTitle & " -->"
Else
fPage.WriteLine "<!DOCTYPE HTML PUBLIC ""-//W3C//DTD HTML 4.01//EN"" ""http://www.w3.org/TR/html4/loose.dtd"">"
fPage.WriteLine "<html>" & vbCr
fPage.WriteLine "<head>" & vbCr
'fPage.WriteLine "<meta http-equiv=""Content-Type"" content=""text/html;charset=UTF-8"">" & vbCr
fPage.WriteLine "<style type=""text/css"">" & vbCr
fPage.WriteLine "body, td, tr, p, h1, h2, h3 { font-family: arial, helvetica, sans-serif; color: #00008B; font-size: 100% }" & vbCr
fPage.WriteLine "a { color: #0000FF }" & vbCr
fPage.WriteLine "a:hover { color: #8F0000}" & vbCr
fPage.WriteLine "</style>" & vbCr
strTitle = removeHTML(Cells(RowStart, ColStart))
fPage.WriteLine "<title>" & strTitle & "</title>" & vbCr ' Use first cell as title
'Note you may want to use your own style sheets or just remove the sheets entirely
If blnIFrame Then
fPage.WriteLine "<link rel=""StyleSheet"" href=""http://balch.org/iframe.css"" TYPE=""text/css"">" & vbCr
Else
fPage.WriteLine "<link rel=""StyleSheet"" href=""http://balch.org/excel.css"" TYPE=""text/css"">" & vbCr
End If
fPage.WriteLine "</head>" & vbCr
sTable = "<table bgcolor=""#FFFFFF"" border=""1"" align=""center"" >"
If blnIFrame Then
fPage.WriteLine "<body >" & vbCr
sTable = "<table bgcolor=""#FFFFFF"" border=""1"" align=center width=""100%"" >" & vbCr
Else
fPage.WriteLine "<body bgcolor=""#9F9F9F"" >" & vbCr
End If
End If
fPage.WriteLine sTable & vbCr
While Row < RowCount
Row = Row + 1
DoEvents
If (Not Range(MyRange).Rows(Row).Hidden) Then
MV = ""
Col = 0
While Col < ColCount
Col = Col + 1
CellV = ""
CellA = ""
If (Not Range(MyRange).Columns(Col).Hidden) Then
'Define cell color
lRGB = Range(MyRange).Cells(Row, Col).Interior.Color
Red = Hex(lRGB And 255)
If Len(Red) = 1 Then Red = "0" & Red
Green = Hex(lRGB \ 256 And 255)
If Len(Green) = 1 Then Green = "0" & Green
Blue = Hex(lRGB \ 256 ^ 2 And 255)
If Len(Blue) = 1 Then Blue = "0" & Blue
BGC = " bgcolor=""#" & Red & Green & Blue & """ "
If BGC = " bgcolor=""#FFFFFF"" " Then BGC = ""
CellV = Range(MyRange).Cells(Row, Col).Text
If CellV = "" Then
CellV = "<br />"
Else
'Adjust Text
If Left(CellV, 1) <> "<" Then CellV = Replace(CellV, Chr(10), (Chr(10) & "<br />")) 'Add Line Feeds unless HTML
'Proposed by Dan Hinz Not used as it looks like it converts the entire cell to the first hyperlink.
' If Range(MyRange).Cells(Row, Col).Hyperlinks.Count = 1 Then
' CellVH = "<a href=""" & Range(MyRange).Cells(Row, Col).Hyperlinks(1).Address & """ target=""NewPage"">"
' CellV = CellVH & Range(MyRange).Cells(Row, Col).Text & "</a>"
' End If
'Add Link to my home page
Select Case sCaller
Case "AWC"
CellV = Replace(CellV, "Charles V. Balch PhD", "<a href=""http://virgil.azwestern.edu/~cvb"">Charles V. Balch PhD</a>", 1, -1, vbTextCompare)
Case "CVB"
CellV = Replace(CellV, "Charles V. Balch", "<a href=""http://charlie.balch.org"">Charles V. Balch</a>", 1, -1, vbTextCompare)
Case "NAU"
CellV = Replace(CellV, "Charles V. Balch PhD", "<a href=""http://oak.ucc.nau.edu/cvb23/"">Charles V. Balch PhD</a>", 1, -1, vbTextCompare)
End Select
'Define cell alignment
Hza = Range(MyRange).Cells(Row, Col).HorizontalAlignment
CellA = " align=""left"" "
If IsNumeric(CellV) Then CellA = " align=""right"" "
If Hza = -4108 Then CellA = " align=""center"" "
If Hza = -4131 Then CellA = " align=""left"" "
If Hza = -4152 Then CellA = " align=""right"" "
If Range(MyRange).Cells(Row, Col).Font.Bold Then CellV = "<b>" & CellV & "</b>"
If Range(MyRange).Cells(Row, Col).Font.Italic Then CellV = "<i>" & CellV & "</i>"
CellVA = ""
vCA = Range(MyRange).Cells(Row, Col).VerticalAlignment
If vCA = -4160 Then CellVA = " style=""vertical-align: top"" "
If vCA = -4107 Then CellVA = " style=""vertical-align: bottom"" "
If vCA = -4108 Then CellVA = " style=""vertical-align: middle"" "
'Define cell font color
lRGB = Range(MyRange).Cells(Row, Col).Font.Color
SFC1 = ""
Red = Hex(lRGB And 255)
If Len(Red) = 1 Then Red = "0" & Red
Green = Hex(lRGB \ 256 And 255)
If Len(Green) = 1 Then Green = "0" & Green
Blue = Hex(lRGB \ 256 ^ 2 And 255)
If Len(Blue) = 1 Then Blue = "0" & Blue
SFC1 = "<font color=""#" & Red & Green & Blue & """ > "
If SFC1 = "<font color=""#000000"" > " Then
SFC1 = ""
SFC2 = ""
Else
SFC2 = "</font>"
End If
End If
'Check for Merged Cells (rows only)
If Hza = 7 Or Range(MyRange).Cells(Row, Col).MergeCells Then
ColSpan = 0
SameTitle = True
While (Range(MyRange).Cells(Row, Col).HorizontalAlignment = 7 Or Range(MyRange).Cells(Row, Col).MergeCells) And SameTitle
' The following code must be changed for versions of Excel earlier than 97
If Not Range(MyRange).Columns(Col).Hidden Then ColSpan = ColSpan + 1
Col = Col + 1
If Len(Range(MyRange).Cells(Row, Col).Text) > 1 Or Not Range(MyRange).Cells(Row, Col).MergeCells Then
SameTitle = False
Col = Col - 1
End If
Wend
If ColSpan > ColCount Then ColSpan = ColCount
CellA = CellA & " colspan=""" & ColSpan & """ "
End If
'Check for Comment (Idea from Michal Matula)
sComment = funTestForComment(Range(MyRange).Cells(Row, Col))
If sComment <> "" Then 'The cell does not have a comment
sComment = Replace(sComment, Chr(34), Chr(147))
sComment = " title=""" & sComment & """"
CellV = "<a name=""Comment"" " & sComment & " >" & CellV & "</a>"
End If
MV = MV & "<td " & CellA & BGC & CellVA & ">" & SFC1 & CellV & SFC2 & "</td>"
End If
Wend
fPage.WriteLine "<tr>" & vbCr & MV & vbCr & "</tr>" & vbCr
End If
Wend
fPage.WriteLine "</table>" & vbCr
If Not blnBoilerPlate Then
fPage.WriteLine "</body>" & vbCr
fPage.WriteLine "</html>" & vbCr
Else
fPage.WriteLine "<!-- End Boilerplate -->"
End If
fPage.Close
Set fPage = Nothing
Set fso = Nothing
End Sub