Excelセル内の書式設定されたテキストへのタグを持つHTMLテキスト
HTMLを取得してExcelにインポートし、リッチテキストとしてフォーマットする（できればVBAを使用して）方法はありますか？基本的に、Excelセルに貼り付けるとき、これを有効にしようとしています。
<html><p>This is a test. Will this text be <b>bold</b> or <i>italic</i></p></html>
これに：
これはテストです。このテキストは 大胆な または イタリック
はい、可能です:)実際には、Internet Explorerがあなたのために汚い仕事をします;）
試行およびテスト済み
私の仮定
- HTMLテキストはSheet1のセルA1にあると仮定しています。代わりに変数を使用することもできます。
- Html値でいっぱいの列がある場合は、次のコードをループに入れるだけです
CODE
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
スナップショット
HTH
シド
HTMLコードをクリップボードにコピーし、特別なコードをUnicodeテキストとして貼り付けることができます。 Excelはセル内にHTMLをレンダリングします。この投稿を確認してください http://www.dailydoseofexcel.com/archives/2005/02/23/html-in-cells-ii/
投稿の関連マクロコード：
Private Sub Worksheet_Change(ByVal Target As Range)
Dim objData As DataObject
Dim sHTML As String
Dim sSelAdd As String
Application.EnableEvents = False
If Target.Cells.Count = 1 Then
If LCase(Left(Target.Text, 6)) = "<html>" Then
Set objData = New DataObject
sHTML = Target.Text
objData.SetText sHTML
objData.PutInClipboard
sSelAdd = Selection.Address
Target.Select
Me.PasteSpecial "Unicode Text"
Me.Range(sSelAdd).Select
End If
End If
Application.EnableEvents = True
End Sub
私はこのスレッドが古いことを知っていますが、innerHTMLを割り当てた後、ExecWBは私のために働きました：
.ExecWB 17, 0
'Select all contents in browser
.ExecWB 12, 2
'Copy them次に、内容をExcelに貼り付けます。これらのメソッドはランタイムエラーが発生しやすいのですが、デバッグモードで1〜2回試行した後は正常に機能するため、Excelでエラーが発生した場合は再試行するように指示する必要があります。このエラーハンドラーをsubに追加することでこれを解決しましたが、正常に動作します。
Sub ApplyHTML()
On Error GoTo ErrorHandler
...
Exit Sub
ErrorHandler:
Resume
'I.e. re-run the line of code that caused the error
Exit Sub
End SubIEの例が機能しない場合は、これを使用してください。とにかく、これはIEのインスタンスを起動するよりも速いはずです。
これはに基づいた完全なソリューションです
http://www.dailydoseofexcel.com/archives/2005/02/23/html-in-cells-ii/
InnerHTMLがすべて数字の場合（例： '12345'）、HTMLの書式設定はExcelで完全に機能しないことに注意してください。ただし、末尾にスペースなどの文字を追加します。 12345 + "＆nbsp;"フォーマットはOK。
Sub test()
Cells(1, 1).Value = "<HTML>1<font color=blue>a</font>" & _
"23<font color=red>4</font></HTML>"
Dim rng As Range
Set rng = ActiveSheet.Cells(1, 1)
Worksheet_Change rng, ActiveSheet
End Sub
Private Sub Worksheet_Change(ByVal Target As Range, ByVal sht As Worksheet)
Dim objData As DataObject ' Set a reference to MS Forms 2.0
Dim sHTML As String
Dim sSelAdd As String
Application.EnableEvents = False
If Target.Cells.Count = 1 Then
Set objData = New DataObject
sHTML = Target.Text
objData.SetText sHTML
objData.PutInClipboard
Target.Select
sht.PasteSpecial Format:="Unicode Text"
End If
Application.EnableEvents = True
End Sub
元のソリューションのコメントでBornToCodeが最初に特定したのと同じエラーに遭遇しました。 ExcelとVBAに慣れていないので、tiQUのソリューションを実装する方法を理解するのに少し時間がかかりました。だから私はそれを以下の「ダミー」ソリューションとして投稿しています
- 最初にExcelで開発者モードを有効にします： Link
- [開発]タブ> [Visual Basic]を選択します
- [表示]> [コード]をクリックします
- 以下のコードを貼り付けて、セル参照を正しくする必要がある行を更新します。
- 緑色の実行矢印をクリックするか、F5を押します
Sub Sample()
Dim Ie As Object
Set Ie = CreateObject("InternetExplorer.Application")
With Ie
.Visible = False
.Navigate "about:blank"
.document.body.InnerHTML = Sheets("Sheet1").Range("I2").Value
'update to the cell that contains HTML you want converted
.ExecWB 17, 0
'Select all contents in browser
.ExecWB 12, 2
'Copy them
ActiveSheet.Paste Destination:=Sheets("Sheet1").Range("J2")
'update to cell you want converted HTML pasted in
.Quit
End With
End Sub
いいね！とても滑らか。
Excelがマージされたセルに貼り付けられず、「ターゲット」セルの下の連続する行にブレークを含む結果も貼り付けられないことに失望しました。いくつかの微調整（アンマージ/再マージなど）を試みましたが、Excelはブレークの下に何かをドロップしたため、行き止まりでした。
最終的に、単純なタグを処理し、マージされたフィールドで問題を引き起こしている「ネイティブ」Unicodeコンバーターを使用しないルーチンを思い付きました。これが他の人にも役立つことを願っています：
Public Sub AddHTMLFormattedText(rngA As Range, strHTML As String, Optional blnShowBadHTMLWarning As Boolean = False)
' Adds converts text formatted with basic HTML tags to formatted text in an Excel cell
' NOTE: Font Sizes not handled perfectly per HTML standard, but I find this method more useful!
Dim strActualText As String, intSrcPos As Integer, intDestPos As Integer, intDestSrcEquiv() As Integer
Dim varyTags As Variant, varTag As Variant, varEndTag As Variant, blnTagMatch As Boolean
Dim intCtr As Integer
Dim intStartPos As Integer, intEndPos As Integer, intActualStartPos As Integer, intActualEndPos As Integer
Dim intFontSizeStartPos As Integer, intFontSizeEndPos As Integer, intFontSize As Integer
varyTags = Array("<b>", "</b>", "<i>", "</i>", "<u>", "</u>", "<sub>", "</sub>", "<sup>", "</sup>")
' Remove unhandled/unneeded tags, convert <br> and <p> tags to line feeds
strHTML = Trim(strHTML)
strHTML = Replace(strHTML, "<html>", "")
strHTML = Replace(strHTML, "</html>", "")
strHTML = Replace(strHTML, "<p>", "")
While LCase(Right$(strHTML, 4)) = "</p>" Or LCase(Right$(strHTML, 4)) = "<br>"
strHTML = Left$(strHTML, Len(strHTML) - 4)
strHTML = Trim(strHTML)
Wend
strHTML = Replace(strHTML, "<br>", vbLf)
strHTML = Replace(strHTML, "</p>", vbLf)
strHTML = Trim(strHTML)
ReDim intDestSrcEquiv(1 To Len(strHTML))
strActualText = ""
intSrcPos = 1
intDestPos = 1
Do While intSrcPos <= Len(strHTML)
blnTagMatch = False
For Each varTag In varyTags
If LCase(Mid$(strHTML, intSrcPos, Len(varTag))) = varTag Then
blnTagMatch = True
intSrcPos = intSrcPos + Len(varTag)
If intSrcPos > Len(strHTML) Then Exit Do
Exit For
End If
Next
If blnTagMatch = False Then
varTag = "<font size"
If LCase(Mid$(strHTML, intSrcPos, Len(varTag))) = varTag Then
blnTagMatch = True
intEndPos = InStr(intSrcPos, strHTML, ">")
intSrcPos = intEndPos + 1
If intSrcPos > Len(strHTML) Then Exit Do
Else
varTag = "</font>"
If LCase(Mid$(strHTML, intSrcPos, Len(varTag))) = varTag Then
blnTagMatch = True
intSrcPos = intSrcPos + Len(varTag)
If intSrcPos > Len(strHTML) Then Exit Do
End If
End If
End If
If blnTagMatch = False Then
strActualText = strActualText & Mid$(strHTML, intSrcPos, 1)
intDestSrcEquiv(intSrcPos) = intDestPos
intDestPos = intDestPos + 1
intSrcPos = intSrcPos + 1
End If
Loop
' Clear any bold/underline/italic/superscript/subscript formatting from cell
rngA.Font.Bold = False
rngA.Font.Underline = False
rngA.Font.Italic = False
rngA.Font.Subscript = False
rngA.Font.Superscript = False
rngA.Value = strActualText
' Now start applying Formats!"
' Start with Font Size first
intSrcPos = 1
intDestPos = 1
Do While intSrcPos <= Len(strHTML)
varTag = "<font size"
If LCase(Mid$(strHTML, intSrcPos, Len(varTag))) = varTag Then
intFontSizeStartPos = InStr(intSrcPos, strHTML, """") + 1
intFontSizeEndPos = InStr(intFontSizeStartPos, strHTML, """") - 1
If intFontSizeEndPos - intFontSizeStartPos <= 3 And intFontSizeEndPos - intFontSizeStartPos > 0 Then
Debug.Print Mid$(strHTML, intFontSizeStartPos, intFontSizeEndPos - intFontSizeStartPos + 1)
If Mid$(strHTML, intFontSizeStartPos, 1) = "+" Then
intFontSizeStartPos = intFontSizeStartPos + 1
intFontSize = 11 + 2 * Mid$(strHTML, intFontSizeStartPos, intFontSizeEndPos - intFontSizeStartPos + 1)
ElseIf Mid$(strHTML, intFontSizeStartPos, 1) = "-" Then
intFontSizeStartPos = intFontSizeStartPos + 1
intFontSize = 11 - 2 * Mid$(strHTML, intFontSizeStartPos, intFontSizeEndPos - intFontSizeStartPos + 1)
Else
intFontSize = Mid$(strHTML, intFontSizeStartPos, intFontSizeEndPos - intFontSizeStartPos + 1)
End If
Else
' Error!
GoTo HTML_Err
End If
intEndPos = InStr(intSrcPos, strHTML, ">")
intSrcPos = intEndPos + 1
intStartPos = intSrcPos
If intSrcPos > Len(strHTML) Then Exit Do
While intDestSrcEquiv(intStartPos) = 0 And intStartPos < Len(strHTML)
intStartPos = intStartPos + 1
Wend
If intStartPos >= Len(strHTML) Then GoTo HTML_Err ' HTML is bad!
varEndTag = "</font>"
intEndPos = InStr(intSrcPos, LCase(strHTML), varEndTag)
If intEndPos = 0 Then GoTo HTML_Err ' HTML is bad!
While intDestSrcEquiv(intEndPos) = 0 And intEndPos > intSrcPos
intEndPos = intEndPos - 1
Wend
If intEndPos > intSrcPos Then
intActualStartPos = intDestSrcEquiv(intStartPos)
intActualEndPos = intDestSrcEquiv(intEndPos)
rngA.Characters(intActualStartPos, intActualEndPos - intActualStartPos + 1) _
.Font.Size = intFontSize
End If
End If
intSrcPos = intSrcPos + 1
Loop
'Now do remaining tags
intSrcPos = 1
intDestPos = 1
Do While intSrcPos <= Len(strHTML)
If intDestSrcEquiv(intSrcPos) = 0 Then
' This must be a Tag!
For intCtr = 0 To UBound(varyTags) Step 2
varTag = varyTags(intCtr)
intStartPos = intSrcPos + Len(varTag)
While intDestSrcEquiv(intStartPos) = 0 And intStartPos < Len(strHTML)
intStartPos = intStartPos + 1
Wend
If intStartPos >= Len(strHTML) Then GoTo HTML_Err ' HTML is bad!
If LCase(Mid$(strHTML, intSrcPos, Len(varTag))) = varTag Then
varEndTag = varyTags(intCtr + 1)
intEndPos = InStr(intSrcPos, LCase(strHTML), varEndTag)
If intEndPos = 0 Then GoTo HTML_Err ' HTML is bad!
While intDestSrcEquiv(intEndPos) = 0 And intEndPos > intSrcPos
intEndPos = intEndPos - 1
Wend
If intEndPos > intSrcPos Then
intActualStartPos = intDestSrcEquiv(intStartPos)
intActualEndPos = intDestSrcEquiv(intEndPos)
With rngA.Characters(intActualStartPos, intActualEndPos - intActualStartPos + 1).Font
If varTag = "<b>" Then
.Bold = True
ElseIf varTag = "<i>" Then
.Italic = True
ElseIf varTag = "<u>" Then
.Underline = True
ElseIf varTag = "<sup>" Then
.Superscript = True
ElseIf varTag = "<sub>" Then
.Subscript = True
End If
End With
End If
intSrcPos = intSrcPos + Len(varTag) - 1
Exit For
End If
Next
End If
intSrcPos = intSrcPos + 1
intDestPos = intDestPos + 1
Loop
Exit_Sub:
Exit Sub
HTML_Err:
' There was an error with the Tags. Show warning if requested.
If blnShowBadHTMLWarning Then
MsgBox "There was an error with the Tags in the HTML file. Could not apply formatting."
End If
End Sub
これはタグのネストを気にせず、代わりにすべての開始タグに終了タグのみを必要とし、開始タグに最も近い終了タグが開始タグに適用されると仮定します。適切にネストされたタグは正常に機能しますが、不適切にネストされたタグは拒否されず、機能する場合と機能しない場合があります。
HTML/WordをExcelシェイプに配置し、Excelセルで見つけるには：
- HTMLを一時ファイルに書き込みます。
- Word Interop経由で一時ファイルを開きます。
- Wordからクリップボードにコピーします。
- Interop経由でExcelを開きます。
- セルを範囲に設定して選択します。
- 「Microsoft Word文書オブジェクト」としてのPasteSpecial
- Excelの行をShapeの高さに調整します。
このようにして、表やその他のものを含むHTMLでさえ、複数のセルに分割されません。
private void btnPutHTMLIntoExcelShape_Click(object sender, EventArgs e)
{
var fFile = new FileInfo(@"C:\Temp\temp.html");
StreamWriter SW = fFile.CreateText();
SW.Write(hecNote.DocumentHtml);
SW.Close();
Word.Application wrdApplication;
Word.Document wrdDocument;
wrdApplication = new Word.Application();
wrdApplication.Visible = true;
wrdDocument = wrdApplication.Documents.Add(@"C:\Temp\temp.html");
wrdDocument.ActiveWindow.Selection.WholeStory();
wrdDocument.ActiveWindow.Selection.Copy();
Excel.Application excApplication;
Excel.Workbook excWorkbook;
Excel._Worksheet excWorksheet;
Excel.Range excRange = null;
excApplication = new Excel.Application();
excApplication.Visible = true;
excWorkbook = excApplication.Workbooks.Add(Type.Missing);
excWorksheet = (Excel.Worksheet)excWorkbook.Worksheets.get_Item(1);
excWorksheet.Name = "Work";
excRange = excWorksheet.get_Range("A1");
excRange.Select();
excWorksheet.PasteSpecial("Microsoft Word Document Object");
Excel.Shape O = excWorksheet.Shapes.Item(1);
this.Text = $"{O.Height} x {O.Width}";
((Excel.Range)excWorksheet.Rows[1, Type.Missing]).RowHeight = O.Height;
}