如何将HTML文本转换为单元格Microsoft Excel
我也遇到了下面这个问题：
带有标签的HTML文本，用于在Excel单元格中格式化文本
我input的代码作为给定的答案：
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的新手，我不知道该怎么做
我感谢任何帮助
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
参考
或者你可以使用这个macros
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
参考