Работа с HTML: поиск тегов (RegExp) и преобразование HTML в текст

В данной статье приведён код 2 функций, которые позволят вам найти на веб-странице нужные HTML теги,
и преобразовать HTML в текст

Особенность этого кода, - использование регулярных выражений (Regexp) для поиска в HTML

Эти функции лежат в основе моей надстройки «Парсер сайтов»

Пример использования:

' в переменной txt находится исходный код веб-страницы (целиком, или его часть)

' ищем div id="mod-lists", и берем его начинку (innerHTML)
' Индекс 1 после innerHTML означает, что если будет найдено несколько таких тегов, - макрос возьмет только первый
res = GetTags(txt, "div", "id", "mod-lists", "innerHTML 1")
 
 
' ищем ВСЕ теги span класса product (функция вернёт массив значений в переменную arr)
arr = Split(GetTags(txt, "span", "class", "product", "outerHTML"), ARSEP)
 
 
' ищем гиперссылку (тег a класса blue-link), и возвращаем атрибут href
link$ = GetTags(txt, "a", "class", "blue-link", "href")
 
 
' ищем ЛЮБОЙ ТЕГ класса price, и берем последний найденный (last), преобразовав его в текст (ConvertToText)
price = GetTags(txt, "any tag", "class", "price", "ConvertToText last")

Есть возможность удалять теги из HTML (параметр DeleteTags), а также использовать подстановочный символ * до или после значения атрибута.
Можно также выполнять поиск по маске для атрибутов:

' в переменной txt находится исходный код веб-страницы (целиком, или его часть)

' удаляем все div, где имя класса начинается с old
txt = GetTags(txt, "div", "class", "old*", "DeleteTags")
 
 
' ищем ВСЕ гиперссылки по маске /item/
links_array = Split(GetTags(txt, "a", "AttributesPattern", "*/item/*", "href"), ARSEP)

Функцией преобразования HTML в текст (ConvertHTMLtoText) можно воспользоваться отдельно (без функции GetTags)

Весь приведённый ниже код, скопируйте в отдельный стандартный модуль

'---------------------------------------------------------------------------------------
' Module        : modHTML                          excelvba.ru/programmes/Parser
' Author        : Igor Vakhnenko                   Date: 21.02.2016
' info @ excelvba.ru                               Skype: ExcelVBA.ru
'---------------------------------------------------------------------------------------

Public Const ARSEP$ = "%~$"
 
Function REGEXP()
    On Error Resume Next
    Static REGEXP_ As Object
    If REGEXP_ Is Nothing Then Set REGEXP_ = CreateObject("VBScript.RegExp"): REGEXP_.Global = True
    Set REGEXP = REGEXP_
End Function
 
Function GetTags(ByVal txt$, ByVal TagName$, Optional ByVal AttrName$, Optional ByVal AttrValue$, Optional ByVal Result$ = "outerHTML") As String
    ' функция выполняет поиск заданного HTML-тега (или атрибута тега) в HTML коде
    On Error Resume Next
    Dim res$, Pattern$, SelfClosing As Boolean, NeedContent As Boolean, ResultType$, ResultIndex$, ResultsCount&, ind&
    Dim PatternPrefix$, PatternSuffix$, AttrValuePattern$, Add_URL_Prefix$
    Const SelfClosingTags = ",area,base,basefont,br,col,frame,hr,img,input,isindex,link,meta,param,embed,"
    Const ASTERISK_PATTERN = "[A-Za-z0-9_-]*"
    AttrName$ = Trim(AttrName$): AttrValue$ = Trim(AttrValue$): TagName$ = Trim(TagName$)
    If TagName$ = "Any Tag" Then TagName$ = "[a-zA-Z1-6]+"
    If TagName$ = "" Then GetTags = "GetTags ERROR: 'TagName' parameter is blank": Exit Function
 
    If InStr(1, AttrValue$, "*") Then
        If AttrValue$ Like "[*]*" Then AttrValue$ = ASTERISK_PATTERN & Mid(AttrValue$, 2)
        If AttrValue$ Like "*[A-Za-z0-9_-][*]" Then AttrValue$ = Left(AttrValue$, Len(AttrValue$) - 1) & ASTERISK_PATTERN
    End If
    PatternPrefix$ = "<(" & TagName$ & ")\b"
    PatternSuffix$ = "[^>]*>"
    Select Case True
        Case AttrName$ & AttrValue$ = ""        ' поиск заданных тегов
            Pattern$ = PatternPrefix$ & PatternSuffix$
 
        Case AttrName$ = "AttributesPattern"        ' поиск тега по шаблону regexp для его заголовка
            If InStr(1, AttrValue$, ">") + InStr(1, AttrValue$, "<") Then _
               GetTags = "GetTags ERROR: 'AttributeValue' parameter contains unacceptable symbols ('<' or '>')": Exit Function
            Pattern$ = PatternPrefix$ & "[^>]*" & AttrValue$ & PatternSuffix$
 
        Case Else        ' поиск тегов по атрибуту name / id / class
            AttrValuePattern$ = "(?:(?:" & AttrValue$ & "\b)|(?:['""](|[^<>'""]* )\b" & AttrValue$ & "\b(| [^<>'""]*)['""]))"
            Pattern$ = PatternPrefix$ & "[^>]*\b" & AttrName$ & "\s*=\s*" & AttrValuePattern$ & PatternSuffix$
    End Select
 
    Result$ = Application.Trim(Result$): If Result$ = "" Then GetTags = "GetTags ERROR: 'Result' parameter is blank": Exit Function
    ResultType$ = Split(Result$)(0)
    ResultIndex$ = Split(Result$, , 2)(1)
 
 
    SelfClosing = SelfClosingTags Like "*," & TagName$ & ",*"
    NeedContent = InStr(1, "|innerHTML|outerHTML|ConvertToText|DeleteTags|", "|" & ResultType$ & "|") > 0
 
    Dim v, content$, cnt&, i&, TextAfterHeader$, TagHeader$, attr$, txtlen&, NN&
    With REGEXP
        .IgnoreCase = True: .Pattern = Pattern$
StartSearching:
        If .test(txt) Then
            For Each v In .Execute(txt)
                DoEvents
                TagHeader$ = "": TagHeader$ = v.Value
 
                If NeedContent And Not SelfClosing Then
                    TagName$ = v.submatches.Item(0)
                    TextAfterHeader$ = "": TextAfterHeader$ = Mid(txt, v.FirstIndex + Len(TagHeader$) + 1)
                    content$ = GetTagInnerHTML(TextAfterHeader$, TagName$)
                    If (ResultType$ = "outerHTML") Or (ResultType$ = "DeleteTags") Then
                        content$ = TagHeader$ & content$ & "</" & TagName$ & ">"
                    End If
                Else
                    content$ = TagHeader$
                End If
                Select Case ResultType$
                    Case "innerHTML", "outerHTML", "TagHeaderOnly"        ' do nothing
                    Case "DeleteTags"
                        txtlen& = Len(txt): txt = Replace(txt, content$, "")
                         ' защита от зацикливания, - если замена не выполнилась, то больше не пытаемся
                       content$ = "": If Len(txt) < txtlen& Then GoTo StartSearching
                    Case "ConvertToText"        ' convert to text
                        content$ = ConvertHTMLtoText(content$)
                    Case Else        ' get attribute value
                        attr$ = "": content$ = Split(content$, ">")(0)
                        content$ = Replace(Replace(content$, "= ", "="), " =", "=")
                        attr$ = Trim(Split(content$, " " & ResultType$ & "=", 2)(1))
                        Select Case Mid(attr$, 1, 1)
                            Case """", "'": attr$ = Split(attr$, Mid(attr$, 1, 1))(1)
                            Case Else: attr$ = Split(attr$, " ")(0)
                        End Select
                        content$ = ConvertHTMLtoText(attr$)        ' для замены  &amp; на & (и подобных других замен)
                       
                End Select
 
                If Len(content$) Then
                    ResultsCount& = ResultsCount& + 1
                    GetTags = GetTags & IIf(Len(GetTags), ARSEP, "") & content$
                    If Val(ResultIndex$) Then If Val(ResultIndex$) = ResultsCount& Then GetTags = content$: Exit Function
                End If
            Next
        End If
    End With
 
    If ResultType$ = "DeleteTags" Then GetTags = txt: Exit Function
 
    If ResultIndex$ = "join" Then GetTags = Replace(GetTags, ARSEP, vbNewLine): Exit Function
 
    If Len(ResultIndex$) * Len(GetTags) Then        ' если указан номер элемента массива
        If InStr(1, ResultIndex$, "last", vbTextCompare) > 0 Then
            ind& = UBound(Split(GetTags, ARSEP)) + Val(Split(ResultIndex$, "last")(1))
        Else
            ind& = Fix(Val(ResultIndex$)) - 1
        End If
 
        If ind& >= 0 And ind& <= UBound(Split(GetTags, ARSEP)) Then
            GetTags = Split(GetTags, ARSEP)(ind&)
        Else
            GetTags = ""
        End If
    End If
End Function
Function GetTagInnerHTML(ByVal txt$, ByVal TagName$) As String
    On Error Resume Next
    Dim ClosingTag$, arr, i&, nOPENING&
    ClosingTag$ = "</" & TagName$ & ">"
    If InStr(1, txt, ClosingTag$, vbTextCompare) = 0 Then Exit Function
    arr = Split(txt, ClosingTag$, , vbTextCompare)
    For i = LBound(arr) To UBound(arr) - 1        ' если убрать -1, то будет выводить и содержимое незакрытого тега (до конца текста в txt$)
        If Len(arr(i)) Then
            nOPENING& = nOPENING& + UBound(Split(arr(i), "<" & TagName$ & ">")) + UBound(Split(arr(i), "<" & TagName$ & " "))
        End If
        GetTagInnerHTML = GetTagInnerHTML & arr(i) & IIf(nOPENING& <> i, ClosingTag$, "")
        If nOPENING& = i Then Exit Function
    Next i
    GetTagInnerHTML = ""
End Function
Function ConvertHTMLtoText(ByVal txt$, Optional RemoveExtraLF As Boolean = False) As String
    ' Функция преобразует HTML в текст без использования DOM
    ' Создание функции было обусловлено утечками памяти при использовании библиотеки MSHTML
    On Error Resume Next
    Const HTML_SP$ = "nbsp=32;pound=163;euro=8364;para=182;sect=167;copy=169;reg=174;trade=8482;deg=176;plusmn=177;frac14=188;frac12=189;" & _
          "frac34=190;times=215;divide=247;fnof=402;Alpha=913;Beta=914;Gamma=915;Delta=916;Epsilon=917;Zeta=918;Eta=919;Theta=920;" & _
          "Iota=921;Kappa=922;Lambda=923;Mu=924;Nu=925;Xi=926;Omicron=927;Pi=928;Rho=929;Sigma=931;Tau=932;Upsilon=933;Phi=934;" & _
          "Chi=935;Psi=936;Omega=937;alpha=945;beta=946;gamma=947;delta=948;epsilon=949;zeta=950;eta=951;theta=952;iota=953;kappa=954;" & _
          "lambda=955;mu=956;nu=957;xi=958;omicron=959;pi=960;rho=961;sigma=963;tau=964;upsilon=965;phi=966;chi=967;psi=968;omega=969;" & _
          "sigmaf=962;larr=8592;uarr=8593;rarr=8594;darr=8595;harr=8596;spades=9824;clubs=9827;hearts=9829;" & _
          "diams=9830;quot=34;amp=38;lt=60;gt=62;hellip=8230;prime=8242;ndash=8211;mdash=8212;lsquo=8216;rsquo=8217;sbquo=8218;" & _
          "ldquo=8220;rdquo=8221;bdquo=8222;laquo=171;raquo=187;ensp=8194;emsp=8195;shy=173;ordm=186;ordf=170;permil=8240;brvbar=166;" & _
          "micro=181;oline=8254;acute=180;sup1=185;sup2=178;sup3=179;not=172;frasl=8260;minus=8722;le=8804;ge=8805;asymp=8776;ne=8800;" & _
          "equiv=8801;radic=8730;infin=8734;sum=8721;prod=8719;part=8706;int=8747;forall=8704;exist=8707;empty=8709;Oslash=216;" & _
          "isin=8712;notin=8713;ni=8727;sub=8834;sup=8835;nsub=8836;sube=8838;supe=8839;oplus=8853;otimes=8855;perp=8869;ang=8736;" & _
          "and=8743;or=8744;cap=8745;cup=8746;cent=162;current=164;yen=165;bull=8226;middot=183;loz=9674;crarr=8629"
 
    Const ADD_TAB$ = "</th><th>,</td><td>"
    Const ADD_NL$ = "<div>,<p>,<table>,</table>,<img>,<h1>,<h2>,<h3>,<h4>,<h5>,<h6>,<br>,<hr>,</tr>,</li>,<dl>,<dt>"
 
    Dim Tag, char, arr, cnt&, i&
    With REGEXP
 
        ' удаляем все комменты из HTML
        If txt$ Like "*<!--*-->*" Then
            arr = "": arr = Split(txt, "<!--")
            For i = LBound(arr) + 1 To UBound(arr)
                cnt& = 0: cnt& = UBound(Split(arr(i), "-->"))
                If cnt& = 0 Then arr(i) = "" Else arr(i) = Split(arr(i), "-->")(cnt&)
            Next i
            txt = Join(arr, "")
        End If
        txt$ = CloseUnclosedTags(txt$)
        ' очистка тегов
        .Pattern = "(<[A-Za-z1-6]+)[^<>]*(>)"
        txt$ = .Replace(txt$, "$1$2")        ' удаляем все атрибуты у тегов
        .Pattern = ">\s*<"
        txt$ = .Replace(txt$, "><")        ' удаляем пробелы и переводы строк между тегами

        ' удаляем все скрипты
        If txt$ Like "*<script>*</script>*" Then
            arr = "": arr = Split(txt, "<script>")
            For i = LBound(arr) + 1 To UBound(arr)
                cnt& = 0: cnt& = UBound(Split(arr(i), "</script>"))
                If cnt& = 0 Then arr(i) = "" Else arr(i) = Split(arr(i), "</script>")(cnt&)
            Next i
            txt = Join(arr, "")
        End If
 
        ' берём содержимое тега <body>
        If txt Like "*<body>*" Then txt = Split(txt, "<body>")(1)
 
        txt = Replace(txt, vbNewLine, vbLf): txt = Replace(txt, vbLf, vbNewLine)
        MultiReplace txt, "<br>" & vbNewLine, "<br>"
        MultiReplace txt, vbNewLine & "<br>", "<br>"
 
        ' добавляем переводы строк и табуляцию между ячейками таблиц
        For Each Tag In Split(ADD_NL$, ",")
            txt = Replace(txt, Tag, vbNewLine, , , vbTextCompare)
        Next Tag
        For Each Tag In Split(ADD_TAB$, ",")
            txt = Replace(txt, Tag, vbTab, , , vbTextCompare)
        Next Tag
 
        ' удаляем оставшиеся теги
        .Pattern = "<[^<>]+>"
        txt$ = .Replace(txt$, "")
        ' заменяем коды спецсимволов на сами символы
        For Each char In Split(HTML_SP$, ";")        ' сначала - символы, которые имеют названия типа &сopy; и &nbsр;
            If InStr(1, txt$, Split(char, "=")(0), vbBinaryCompare) Then
                txt$ = Replace(txt$, "&" & Split(char, "=")(0) & ";", ChrW(Val(Split(char, "=")(1))), , , vbBinaryCompare)
            End If
        Next char
        .Pattern = "&#(\d{2,5});"        ' а теперь - спецсимволы, представленные кодами вида &#84l0;
        If .test(txt$) Then
            For Each char In .Execute(txt)
                txt$ = Replace(txt$, char.Value, ChrW(Val(char.submatches.Item(0))))
            Next
        End If
 
        ' убираем лишние переводы строк, пробелы и табуляторы
        MultiReplace txt, " " & vbTab, vbTab: MultiReplace txt, vbTab & " ", vbTab
        MultiReplace txt, vbTab & vbNewLine, vbNewLine: MultiReplace txt, vbNewLine & vbTab, vbNewLine
        MultiReplace txt$, vbNewLine & vbNewLine & vbNewLine, vbNewLine & vbNewLine
        MultiReplace txt, vbNewLine & " " & vbNewLine, vbNewLine
        MultiReplace txt, " " & vbNewLine, vbNewLine
 
        If RemoveExtraLF Then MultiReplace txt$, vbNewLine & vbNewLine, vbNewLine
 
        While txt$ Like "*" & vbNewLine: txt = Left(txt, Len(txt) - Len(vbNewLine)): Wend
        While txt$ Like vbNewLine & "*": txt = Mid(txt, Len(vbNewLine) + 1): Wend
 
    End With
    Erase arr: Err.Clear
    ConvertHTMLtoText = txt$
End Function
Sub MultiReplace(ByRef txt$, ByVal Find$, ByVal Replacement$)
    On Error Resume Next: Dim n&
    If InStr(1, Replacement$, Find$, vbBinaryCompare) Then Exit Sub        ' чтобы избежать зацикливания и переполнения
    While (InStr(1, txt$, Find$, vbBinaryCompare) > 0) And (n < 100)
        n = n + 1: txt$ = Replace(txt$, Find$, Replacement$)
    Wend
End Sub
 
Function CloseUnclosedTags(ByVal txt$) As String
    On Error Resume Next: CloseUnclosedTags = txt$: Dim char
    With REGEXP
        .Pattern = "(<[A-Za-z1-6]+\b[^<>]*)(<[A-Za-z1-6]+\b)"
        If .test(txt$) Then CloseUnclosedTags = .Replace(txt$, "$1>$2")
    End With
End Function

Комментарии

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Добрый день!
Можно ли удалить (или закрыть) незакрытые теги

Пример:
<p></i><b>Размер</b>: 70м<br /><b><a href="http://ya.ru"><p

Могут быть лишние закрывающие теги, незакрытые теги,
а могут быть и разорванные (незавершенные)

Хотелось бы получить подобное

Пример:
<p><b>Размер</b>: 70м<br /><b><a href="http://ya.ru"></a></b></p>

т.е.
лишний закрывающий тег i - удалён
незавершенный (разорванный) тег P удалён
и далее, последовательно закрыты все открытые теги

Если можно, то как?
если можно частично, то тоже хотелось бы пример.

С уважением.

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

Sub test()
Range("E2").Select

Do Until IsEmpty(ActiveCell)
txt = GetHTTPResponse(ActiveCell)
res = GetTags(txt, "tr", "class", "hi_sys poi stat_reged", "onclick")

ПутьКРабочемуСтолу = CreateObject("WScript.Shell").SpecialFolders("Desktop")
AddIntoTXTfile ПутьКРабочемуСтолу & "\PageText.txt", res
ActiveCell.Offset(1, 0).Select
Loop
MsgBox "Готово"
End Sub

Спасибо !

Ничего заново не загружаю. Указываю брать данные из нужного столбца и всё.

Здравствуйте
я недавно на сайте в статьях заголовки менял, - и случайно зацепил код этого макроса
потому и не работает

Замените строку кода

Const ADD_NL$ = "<div>,<p>,<table>,</table>,<img>,<p class="h1">,<p class="h2">,<p class="h3">,<p class="h4">,<p class="h5">,<p class="h6">,<br>,<hr>,</tr>,</li>"

на
Const ADD_NL$ = "<div>,<p>,<table>,</table>,<img>,<h1>,<h2>,<h3>,<h4>,<h5>,<h6>,<br>,<hr>,</tr>,</li>,<dl>,<dt>"

и всё должно заработать

PS: парсер эту задачу выполнит быстро, никаких 2 часов тут не нужно, несколько минут максимум.
Это если не прогружать все страницы заново, а брать исходные данные (HTML код) с листа из первого столбца (как ваш макрос делает), и выводить 3 столбца на лист

Добрый день.
Пользуюсь вашим парсером, отличная программа.
Ей я спарсил 100000 страниц в итоге в колонке у меня получились вот такие данные.
Символы <> в комментарии заменил на html сущности для наглядности.
<a class="strong" href="/а бабах" title="Категория «а бабах»" data-toggle="tooltip">а бабах</a>
<a class="strong" href="/ирония" title="Категория «ирония»" data-toggle="tooltip">ирония</a>
Теперь мне нужно достать href, innerhtml, title - парсером без проблем но по времени 2,5 часа при условии что я отключил прокручивание и сделал вывод по 200. - это долго.

Решил попробовть вашу функцию, загнал всё в массив и в цикле попробовал в общем

arrProiz(g, 2) = GetTags(arrProiz(g, 1), "a", "class", "strong", "innerHTML 1") данный код работает
arrProiz(g, 3) = GetTags(arrProiz(g, 1), "a", "", "", "href") - этот не работает.
arrProiz(g, 4) = GetTags(arrProiz(g, 1), "a", "", "", "title") - этот тоже не работает.

Выводит ошибку syntax error и выделяет строку

Const ADD_NL$ = ",,,,,,,,,,,,,,

"

Что может быть ?

Заранее спасибо.

Да, возможно, - если у этих тегов есть что-то общее (название тега, или атрибут какой)
Иначе не понятно, как выделить именно 2 тега 'span' и 'a' среди сотни других тегов (в том числе тех же 'span' и 'a')
Можно и все теги найти, если в качестве имени тега написать 'Any Tag'

Добрый день.
Подскажите, пожалуйста, а возможно функцией GetTags одновременно (не по очереди ) получить данные двух тегов (например "a" и/или "span") или всех тегов в переменной.

Спасибо.

Алексей, потестируйте это всё в программе-парсере, - там это проще всё делается, - может, и причину найдете, почему не работает
http://excelvba.ru/programmes/Parser
Там это действие называется «HTML: поиск тегов»

Добрый день
Спасибо за пояснения, но некоторые моменты остались непонятны.
Вот например, попробовал разобрать страницу поисковой выдачи яндекс.

Пишу str1 = GetTags(txt, "li", "class", "serp-item t-construct-adapter__legacy", "outerHTML " & n & "")
получаю не совсем то, что ожидал (ожидал код от

  • с внутренним содержимым)
  • Пишу str2 = GetTags(txt, "li", "class", "serp-item t-construct-adapter__legacy", "innerHTML " & n & "")
    получаю пустую строку

    Алексей, ARSEP - это константа, которая используется в качестве разделителя элементов массива в функции GetTags
    (когда функция GetTags возвращает не одно значение, а несколько, - она возвращает текстовую строку вида Значение1 & ARSEP & Значение2 & ARSEP & Значение3)
    Пока другой информации по функции нет.

    Добрый день!
    А не подскажете, что за ARSEP в строчке примера
    arr = Split(GetTags(txt, "span", "class", "product", "outerHTML"), ARSEP)

    И вообще интересно было бы подробнее узнать про использование GetTags. Еесть ли информация кроме данной страницы?

    Елена, при помощи VBA можно сделать что угодно
    «Клик по кнопке» можно сделать 2 способами:
    1) используя браузер (IE), найти элемент, и вызвать для него функцию .Click
    2) без браузера, - посмотреть в коде страницы, что за запрос отправляется на сервер при нажатии на кнопку, и выполнить этот запрос макросом.

    Я не готов вам помогать с макросами по этой теме, - у меня есть готовая программа (парсер сайтов), которая всё это умеет.
    Сидеть же писать отдельные макросы, только потому что «мощный софт» вам не нужен, мне лень.

    А возможно ли по примощи vba сделать клик по спрайт кнопке? например: "icon sprite inline love sprite-button-love"

    <html class="no-touch">
                    <div class="icon sprite inline love sprite-button-love"> 
                    </div>
    </html>

    и клик по ссылке

    <html>
     <body class="oldShare">
                   <div class="action-item favorite-recording">
                    <a class="action-btn" href="javascript://">Favorite</a>
                   </div>
     </body>
    </html>

    для примера структура страницы:
    urlS="https://www.smule.com/p/1061154754_1232830398"

    мне пока ещё сложна для понимания "смесь" HTML и VBA, но очень хочется разобраться :)
    спасибо, за помощь!

    Игорь, спасибо, но такой мощный софт мне не нужен/
    пришлось немного импровизировать и вроде получилось, сели текст скрипта сплитовать
    [vba]

    Sub SmuleSing() ' пример использования
    Application.ScreenUpdating = False
    On Error Resume Next
    txt = GetHTTPResponse("https://www.smule.com/listen/new/9")
    txt = Replace(txt, ThisWorkbook.Sheets("element").Cells(1, 4), "")
    For strElement = 1 To ThisWorkbook.Sheets("element").Cells(Rows.Count, 1).End(xlUp).Row
    elementND = ThisWorkbook.Sheets("element").Cells(strElement, 1)
    For cc = 1 To 26
    If Split(Split(txt, elementND)(cc - 1), """")(0) = "" Then
    ThisWorkbook.Sheets("#out").Cells(ThisWorkbook.Sheets("#out").Cells(Rows.Count, strElement).End(xlUp).Row + 1, strElement) = "Null"
    Else
    ThisWorkbook.Sheets("#out").Cells(ThisWorkbook.Sheets("#out").Cells(Rows.Count, strElement).End(xlUp).Row + 1, strElement) = Split(Split(txt, elementND)(cc - 1), """")(0)
    End If
    Next
    Next strElement
    ThisWorkbook.Sheets("#out").Range("$A$1:$D$" & ThisWorkbook.Sheets("#out").Cells(Rows.Count, 1).End(xlUp).Row).RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlYes

    ThisWorkbook.Sheets("#out").Cells(1, strElement + 1) = "-> " & ThisWorkbook.Sheets("#out").Cells(Rows.Count, 1).End(xlUp).Row - 1

    Application.ScreenUpdating = True

    End Sub
    [/vba]
    элементы на листе "element"
    [a1]= "performance_key":"
    [a2]= "ensemble_type":"
    [a3]= "city":"
    [a4]= "country":"
    список записей выводится на лист "#out"

    Елена, да, это возможно
    Как настраивать (какие действия нужны) — показал на скриншоте:

    Добрый день
    подскажите пожалуйста, возможно ли функцией GetTags получить из
    URLS = "https://www.smule.com/listen/new/9"
    содержание
    а именно из DataStore.Pages.Listen
    Там при запросе 25 записей
    нужны только значения всех этих элементов:
    performance_key
    ensemble_type
    country

    через innerHTML и content не получается

    Получилось, большое спасибо

    Попробуйте такой код:

    Sub test()
        URL$ = "http://ExcelVBA.ru/"
     
        With CreateObject("MSXML2.XMLHTTP")    ' загружаем страницу
            .Open "GET", URL$, False: .send: txt = .responseText
        End With
     
        Title$ = GetTags(txt, "title", "", "", "innerHTML 1")
        MsgBox Title$, vbInformation, "title"
     
        Description$ = GetTags(txt, "meta", "name", "description", "content 1")
        MsgBox Description$, vbInformation, "meta description"
    End Sub

    title можно вытащить так - ie.document.title
    вопрос с meta description остался нерешенным

    Добрай день
    Подскажите пожалуйста, можно ли функцию GetTags с этой страницы использовать для получения со страницы тайтлов и метатегов
    GetTags(txt, "title", "", "", "innerHTML 1") - вот так не получилось

    Отправить комментарий

    Содержание этого поля является приватным и не предназначено к показу.
    CAPTCHA
    Подтвердите, пожалуйста, что вы - человек:
      ____     __         _   ____    _  __  _  __
    | _ \ / /_ | | / ___| | |/ / | |/ /
    | | | | | '_ \ _ | | \___ \ | ' / | ' /
    | |_| | | (_) | | |_| | ___) | | . \ | . \
    |____/ \___/ \___/ |____/ |_|\_\ |_|\_\
    Введите код, изображенный в стиле ASCII-арт.

    Не получается применить макрос? Не удаётся изменить код под свои нужды?

    Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.