Vba excel текст html - Word и Excel - помощь в работе с программами

Пользовательские функции VBA Excel для парсинга сайтов, html-страниц и файлов, возвращающие их текстовое содержимое. Примеры записи текста в переменную.

Парсинг html-страниц (msxml2.xmlhttp)

Пользовательская функция GetHTML1 (VBA Excel) для извлечения (парсинга) текстового содержимого из html-страницы сайта по ее URL-адресу с помощью объекта «msxml2.xmlhttp»:

Function GetHTML1(ByVal myURL As String) As String

On Error Resume Next

With CreateObject(«msxml2.xmlhttp»)

.Open «GET», myURL, False

.send

Do: DoEvents: Loop Until .readyState = 4

GetHTML1 = .responseText

End With

End Function

Парсинг сайтов (WinHttp.WinHttpRequest.5.1)

Пользовательская функция GetHTML2 (VBA Excel) для извлечения (парсинга) текстового содержимого из html-страницы сайта по ее URL-адресу с помощью объекта «WinHttp.WinHttpRequest.5.1»:

Function GetHTML2(ByVal myURL As String) As String

On Error Resume Next

With CreateObject(«WinHttp.WinHttpRequest.5.1»)

.Open «GET», myURL, False

.send

Do: DoEvents: Loop Until .readyState = 4

GetHTML2 = .responseText

End With

End Function

Парсинг файлов (ADODB.Stream)

Пользовательская функция GetText (VBA Excel) для извлечения (парсинга) текстового содержимого из файла (.txt, .csv, .mhtml), сохраненного на диск компьютера, по его полному имени (адресу) с помощью объекта «ADODB.Stream»:

Function GetText(ByVal myFile As String) As String

On Error Resume Next

With CreateObject(«ADODB.Stream»)

.Charset = «utf-8»

.Open

.LoadFromFile myFile

GetText = .ReadText

.Close

End With

End Function

Примеры записи текста в переменную

Общая формула записи текста, извлеченного с помощью пользовательских функций VBA Excel, в переменную:

Dim htmlText As String

htmlText = GetHTML1(«Адрес сайта (html-страницы)»)

htmlText = GetHTML2(«Адрес сайта (html-страницы)»)

htmlText = GetText(«Полное имя файла»)

Конкретные примеры:

htmlText = GetHTML1(«https://internettovary.ru/nabor-dlya-vyrashchivaniya-veshenki/»)

htmlText = GetHTML2(«https://internettovary.ru/nabor-dlya-vyrashchivaniya-veshenki/»)

htmlText = GetText(«C:UsersEvgeniyDownloadsНовый текстовый документ.txt»)

htmlText = GetText(«C:UsersEvgeniyDownloadsИспользование msxml2.xmlhttp в Excel VBA.mhtml»)

В понятие «парсинг», кроме извлечения текстового содержимого сайтов, html-страниц или файлов, входит поиск и извлечение конкретных данных из всего полученного текстового содержимого.

Пример извлечения email-адресов из текста, присвоенного переменной, смотрите в последнем параграфе статьи: Регулярные выражения (объекты, свойства, методы).

Парсинг содержимого тегов

Извлечение содержимого тегов с помощью метода getElementsByTagName объекта HTMLFile:

Sub Primer1()

Dim myHtml As String, myFile As Object, myTag As Object, myTxt As String

‘Извлекаем содержимое html-страницы в переменную myHtml с помощью функции GetHTML1

myHtml = GetHTML1(«https://internettovary.ru/sadovaya-nozhovka-sinitsa/»)

‘Создаем объект HTMLFile

Set myFile = CreateObject(«HTMLFile»)

‘Записываем в myFile текст из myHtml

myFile.body.innerHTML = myHtml

‘Присваиваем переменной myTag коллекцию одноименных тегов, имя которого

‘указанно в качестве аргумента метода getElementsByTagName

Set myTag = myFile.getElementsByTagName(«p»)

‘Выбираем, содержимое какого тега по порядку, начинающегося с 0, нужно извлечь

myTxt = myTag(5).innerText

MsgBox myTxt

‘Большой текст может не уместиться в MsgBox, тогда для просмотра используйте окно Immediate

‘Debug.Print myTxt

End Sub

С помощью этого кода извлекается текст, расположенный между открывающим и закрывающим тегами. В примере — это текст 6-го абзаца (p) между 5-й (нумерация с 0) парой отрывающего <p> и закрывающего </p> тегов.

Примеры тегов, используемых в html: "p", "title", "h1", "h2", "table", "div", "script".

Пример извлечения содержимого тега "title":

Sub Primer2()

Dim myHtml As String, myFile As Object, myTag As Object, myTxt As String

myHtml = GetHTML1(«https://internettovary.ru/sadovaya-nozhovka-sinitsa/»)

Set myFile = CreateObject(«HTMLFile»)

myFile.body.innerHTML = myHtml

Set myTag = myFile.getElementsByTagName(«title»)

myTxt = myTag(0).innerText

MsgBox myTxt

End Sub

Парсинг содержимого Id

Извлечение текстового содержимого html-элементов, имеющих уникальный идентификатор — Id, с помощью метода getElementById объекта HTMLFile:

Sub Primer3()

Dim myHtml As String, myFile As Object, myTag As Object, myTxt As String

myHtml = GetHTML1(«https://internettovary.ru/sadovaya-nozhovka-sinitsa/»)

Set myFile = CreateObject(«HTMLFile»)

myFile.body.innerHTML = myHtml

‘Присваиваем переменной myTag html-элемент по указанному в скобках Id

Set myTag = myFile.getElementById(«attachment_465»)

‘Присваиваем переменной myTxt текстовое содержимое html-элемента с Id

myTxt = myTag.innerText

MsgBox myTxt

‘Большой текст может не уместиться в MsgBox, тогда для просмотра используйте окно Immediate

‘Debug.Print myTxt

End Sub

Для реализации представленных здесь примеров могут понадобиться дополнительные библиотеки. В настоящее время у меня подключены следующие (к данной теме могут относиться последние шесть):

Visual Basic For Applications
Microsoft Excel 16.0 Object Library
OLE Automation
Microsoft Office 16.0 Object Library
Microsoft Forms 2.0 Object Library
Ref Edit Control
Microsoft Scripting Runtime
Microsoft Word 16.0 Object Library
Microsoft Windows Common Controls 6.0 (SP6)
Microsoft ActiveX Data Objects 6.1 Library
Microsoft ActiveX Data Objects Recordset 6.0 Library
Microsoft HTML Object Library
Microsoft Internet Controls
Microsoft Shell Controls And Automation
Microsoft XML, v6.0

С этим набором библиотек все примеры работают. Тестирование проводилось в VBA Excel 2016.

Источник

Nice! Very slick.

I was disappointed that Excel doesn’t let us paste to a merged cell and also pastes results containing a break into successive rows below the «target» cell though, as that meant it simply doesn’t work for me. I tried a few tweaks (unmerge/remerge, etc.) but then Excel dropped anything below a break, so that was a dead end.

Ultimately, I came up with a routine that’ll handle simple tags and not use the «native» Unicode converter that is causing the issue with merged fields. Hope others find this useful:

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

Note this doesn’t care about tag nesting, instead only requiring a close tag for every open tag, and assuming the close tag nearest the opening tag applies to the opening tag. Properly nested tags will work fine, while improperly nested tags will not be rejected and may or may not work.

Источник

Baria

Пользователь

Сообщений: 11
Регистрация: 11.03.2018

Доброго времени суток! Задача такая: в один из столбцов excel выгружается со страницы формы текст, но он вместе с тэгами HTML, названиями полей.
Как убрать весь технический набор символов и оставить только текст — в частности это русские буквы? Спасибо!

Изменено: Baria — 11.03.2018 04:53:24

Ігор Гончаренко

Пользователь

Сообщений: 13746
Регистрация: 01.01.1970

11.03.2018 05:15:27

Цитата
Baria написал: и оставить только текст — в частности это русские буквы?

а арабские цифры Вас не интересуют?
а разделительные и другие знаки?

Программисты — это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!

Игорь

Пользователь

Сообщений: 3631
Регистрация: 23.12.2012

11.03.2018 05:26:51

Здесь есть нужный вам код:

http://excelvba.ru/code/html

Код

Function ConvertHTMLtoText(ByVal txt$, Optional RemoveExtraLF As Boolean = False) As String
    ' Функция преобразует HTML в текст без использования DOM
    ' Создание функции было обусловлено утечками памяти при использовании библиотеки MSHTML
    ' ...
End Function

Baria Пользователь Сообщений: 11 Регистрация: 11.03.2018	Игорь, спасибо, изучаю… Ігор Гончаренко, да арабские и разделители тоже будут встречаться. Интересуют тоже.

Baria

Пользователь

Сообщений: 11
Регистрация: 11.03.2018

18.03.2018 15:13:25

Цитата
Игорь написал: Здесь есть нужный вам код: http://excelvba.ru/code/html

Добрый день! Скажите, а как правильно использовать эту функцию ConvertHTMLtoText ?

У меня в excel есть колонка AB в которой все записи с html тэгами. Как правильно применить функцию, чтобы в колонке AC остался только текст без тэгов ?
Много кода писал на VBA, но c функциями мало сталкивался. Спасибо!

Игорь Пользователь Сообщений: 3631 Регистрация: 23.12.2012	1) скопировать код функции в стандартный модуль в вашем файле 2) написать в ячейке AC2 формулу =ConvertHTMLtoText (AB2) 3) протянуть формулу вниз

Baria Пользователь Сообщений: 11 Регистрация: 11.03.2018	Игорь, спасибо большое!!!

Baria Пользователь Сообщений: 11 Регистрация: 11.03.2018

Baria

Пользователь

Сообщений: 11
Регистрация: 11.03.2018

Добрый день! Функция убирает почти все тэги. Остаются символы: <b>, </b>, <div style-color^red>, <strong> , <strong> , </div> — изучал код, экспериментировал, но не получилось избавится от этих. Подскажите, пожалуйста, куда нужно прописать код и какой, чтобы избавится от вышеприведенных символов? Заранее благодарю за помощь!

Андрей VG

Пользователь

Сообщений: 11878
Регистрация: 22.12.2012

Excel 2016, 365

#10

22.03.2018 11:24:55

Доброе время суток.

Цитата
Baria написал: Функция убирает почти все тэги

Попробуйте элементарную функцию на регулярных выражениях. Без примера, что есть, что должно быть — это как на пальцах разговаривать.

Код

Public Function onlyText(ByVal textVal As String) As String
    Dim pReg As Object
    Set pReg = CreateObject("VBScript.RegExp")
    pReg.Global = True: pReg.Pattern = "<.+?>"
    onlyText = Application.Trim(pReg.Replace(textVal, " "))
End Function

Изменено: Андрей VG — 22.03.2018 11:25:23

Baria

Пользователь

Сообщений: 11
Регистрация: 11.03.2018

#11

22.03.2018 11:45:57

Цитата
Андрей VG написал: Без примера, что есть, что должно быть — это как на пальцах разговаривать.

Игорь, вот что получается:

Скрытый текст

Цель: Чтобы остался только текст. Спасибо Вам за помощь!

Андрей VG

Пользователь

Сообщений: 11878
Регистрация: 22.12.2012

Excel 2016, 365

#12

22.03.2018 12:07:00

Цитата
Baria написал: Игорь, вот что получается

Это вы ко мне? Дык, я не Игорь. А где как нужно? Раз вы даёте половинчатые ответы, получайте частичное решение.

Код

Public Function onlyText(ByVal textVal As String) As String
    Dim pReg As Object
    Set pReg = CreateObject("VBScript.RegExp")
    pReg.Global = True: pReg.Pattern = "<.+?>"
    textVal = Replace$(Replace$(textVal, "&lt;", "<"), "&gt;", ">")
    onlyText = Application.Trim(pReg.Replace(textVal, " "))
End Function

P. S. Функция Игоря, кстати, дала абсолютно правильный результат, с точки зрения форматирования HTML документа и текстового содержимого в нём.

Изменено: Андрей VG — 22.03.2018 12:12:47

Baria

Пользователь

Сообщений: 11
Регистрация: 11.03.2018

Приношу свои извинения, Андрей! Нужно только текст:
«В рамках одного обращения Вы можете задать только один вопрос или сообщить об одной ошибке.Не следует возвращать запрос в работу для дополнительного вопроса. Нужно оформить новое обращение и указать в нём номер исходного.Текст2 Дата, озвучиваемая КлиентуТекст3 Текст3 Текст4 Текст5 Текст6. Текст7 Текст8 Текст9 Текст10. Текст10 ОсновнойТекстВажный Приложить шаблон в соответствии с типом доработки»

Baria Пользователь Сообщений: 11 Регистрация: 11.03.2018	Как убрать оставшиеся символы?

Андрей VG Пользователь Сообщений: 11878 Регистрация: 22.12.2012 Excel 2016, 365	Применить в коде функцию Replace, с указанием что на что поменять. Пример есть в коде. Давайте уж и вы будете участником, а не только Ctrl+C, Ctrl+V

Игорь Пользователь Сообщений: 3631 Регистрация: 23.12.2012	в вашем случае, мою функцию надо применить 2 раза подряд: =ConvertHTMLtoText(ConvertHTMLtoText (AB2))

Baria Пользователь Сообщений: 11 Регистрация: 11.03.2018

Baria

Пользователь

Сообщений: 11
Регистрация: 11.03.2018

Добрый день! Подскажите, пожалуйста, все же лишнее убрано! т.е. код убрал и тот текст, который описывает Label. т.е. наименование поля. Можно ли Эти названия не удалять ?
например часть тэга такая: id=»a2″ label=»Проблема(описание)».
Нужно оставить: «Проблема (описание).

Спасибо!

Изменено: Baria — 23.03.2018 19:17:38

Irregular Expression

Пользователь

Сообщений: 438
Регистрация: 30.10.2017

#19

23.03.2018 17:33:39

Baria, можно. Вот немного доработал функцию АндреяVG, в качестве второго параметра указываете атрибут тега, который надо сохранить:

Код

Public Function onlyTextWithAttributeValue(ByVal textVal As String, ByVal attributeToSave As String) As String
    Dim pReg As Object
    Set pReg = CreateObject("VBScript.RegExp")
    pReg.Global = True: pReg.Pattern = "<.+" & attributeToSave & "=" & Chr(34) & "([^" & Chr(34) & "]*).*>"
    textVal = Replace$(Replace$(textVal, "&lt;", "<"), "&gt;", ">")
    onlyText = Application.Trim(pReg.Replace(textVal, "$1"))
End Function

Правда, учтите, что функция будет чистить только теги, в которых есть заданный атрибут и ему присвоено значение (атрибуты типа readonly без знака равно и значения в кавычках не будут учитываться).

В теории, можно вообще довести регулярное выражение до идеала, но лично мне проще использовать несколько регулярных выражений или даже функций, чем ломать мозг над каждым возможным символом, собирая комплексную задачу в одно регулярное выражение.

В итоге у Вас должно получиться что-то вроде формулы: =onlyText(onlyTextWithAttribute(A1; «label»))

Изменено: Irregular Expression — 23.03.2018 17:34:44

Источник

Nice! Very slick.

Ultimately, I came up with a routine that’ll handle simple tags and not use the «native» Unicode converter that is causing the issue with merged fields. Hope others find this useful:

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

Источник

Why parse HTML in Excel VBA? There may be different cases where we need to parse HTML in Excel. Few cases are generating multiple HTML files based on excel data, editing multiple HTML files, scraping some data etc.

I’m using Hacker News homepage for this example where we parse all the posts from homepage. Of course, Hacker News has its own API which can be used to pull latest topics but this example is just to learn how to parse HTML.

Why Hacker News? Because everyone knows Hacker News!

Final output looks like image below.

Getting started

Microsoft HTML object library is used in parsing HTML.
Open script editor in excel (alt + f11) and add a reference to Microsoft HTML object library (Tools > references > select)

A few basics first and then dive into code!

Defining and setting HTML

HTML object can be defined using :

Dim html As New HTMLDocument

HTML can be set to this object using this syntax :

html.body.innerHTML = htmlstring

Useful methods and properties

There are many methods and properties of HTML object and elements. You can have a look at all the methods using autocomplete but most useful methods are properties are as follows:

getElementsByTagName
getElementsByClassName
getElementById
getAttribute
innerText
innerHTML

Steps

First, we pull Hacker News homepage by making a basic HTTP GET request. Read more about HTTP requests here – Http requests in Excel VBA
Set HTTP response to our HTML object.
Get all the latest topics using getElementsByClass method
Loop through each topic, parse each topic’s title, link, upvotes and username using different methods.
Enter all parsed values to sheet 1

Complete Code

Have a look at the code first.

Public Sub parsehtml()
Dim http As Object, html As New HTMLDocument, topics As Object, titleElem As Object, detailsElem As Object, topic As HTMLHtmlElement
Dim i As Integer
Set http = CreateObject("MSXML2.XMLHTTP")
http.Open "GET", "https://news.ycombinator.com/", False
http.send
html.body.innerHTML = http.responseText
Set topics = html.getElementsByClassName("athing")
i = 2
For Each topic In topics
Set titleElem = topic.getElementsByTagName("td")(2)
Sheets(1).Cells(i, 1).Value = titleElem.getElementsByTagName("a")(0).innerText
Sheets(1).Cells(i, 2).Value = titleElem.getElementsByTagName("a")(0).href
Set detailsElem = topic.NextSibling.getElementsByTagName("td")(1)
Sheets(1).Cells(i, 3).Value = detailsElem.getElementsByTagName("span")(0).innerText
Sheets(1).Cells(i, 4).Value = detailsElem.getElementsByTagName("a")(0).innerText
i = i + 1
Next
End Sub

When I say topics, I mean posts.

Code Explanation

First we define all the required objects like HTMLDocument, MSXML2.XMLHTTP
Topics object to store topics which will be used to loop. I’ve defined few other objects like titleElem and detailsElem to make code readable.
get homepage and set its HTML to our HTML object in line 7
Now we have to get all the topic elements. We have to identify those elements to get them. In this htmlpage, all topic elements have a class named athing so we can use getElementsByClassName method to get those elements.
How to identify elements? By viewing page source or inspecting element in chrome (right click on element > inspect)
In line 8, We get all the topics using getElementsByClassName method by specifying the class name athing. Next we loop through all the topics using a For loop
All the topics are in a table element and each topic is a tr element (row) and topic’s details are in the next tr element. Each row has sub-parts : td elements which have the content like topic name, domain name, upvotes, username etc.

Topic title and domain are in the third td element so we get it using getElementsByTagName("td")(2) (Index starts at 0). Topic name and link is in another a element so we get it using getElementsByTagName("a")(0) and enter its values in sheet 1
Topic details like upvotes and username are in the next element to topic element so we get it using NextSibling method. Get upvotes and username which are in span and a elements and enter in sheet 1.
Integer i is used to store row number which starts at 2 and increments with every topic.

Wrapping up

HTML Elements can also be defined as HTMLBaseElement for auto completion.

There are many ways of identifying an element in HTML. Using ID, Class name, Tag name etc. XPath can also be using to identify element but VBA doesn’t have built-in support for XPath. Here’s a custom function to identify elements using XPath.

Public Function getXPathElement(sXPath As String, objElement As Object) As HTMLBaseElement
Dim sXPathArray() As String

Dim sNodeName As String
Dim sNodeNameIndex As String
Dim sRestOfXPath As String
Dim lNodeIndex As Long
Dim lCount As Long

' Split the xpath statement
sXPathArray = Split(sXPath, "/")
sNodeNameIndex = sXPathArray(1)
If Not InStr(sNodeNameIndex, "[") &gt; 0 Then
sNodeName = sNodeNameIndex
lNodeIndex = 1
Else
sXPathArray = Split(sNodeNameIndex, "[")
sNodeName = sXPathArray(0)
lNodeIndex = CLng(Left(sXPathArray(1), Len(sXPathArray(1)) - 1))
End If
sRestOfXPath = Right(sXPath, Len(sXPath) - (Len(sNodeNameIndex) + 1))

Set getXPathElement = Nothing
For lCount = 0 To objElement.ChildNodes().Length - 1
If UCase(objElement.ChildNodes().item(lCount).nodeName) = UCase(sNodeName) Then
If lNodeIndex = 1 Then
If sRestOfXPath = "" Then
Set getXPathElement = objElement.ChildNodes().item(lCount)
Else
Set getXPathElement = getXPathElement(sRestOfXPath, objElement.ChildNodes().item(lCount))
End If
End If
lNodeIndex = lNodeIndex - 1
End If
Next lCount
End Function

If you have any questions or feedback, comment below.

Author
Recent Posts

A CA- by education, self taught coder by passion, loves to explore new technologies and believes in learn by doing.

Источник