Извлечь все разделенные слова <b>... </b>

Question

У меня проблема с извлечением слов в MS Excel. У меня есть несколько предложений в формате HTML подряд и я хочу извлечь все слова, разделенные <b>....</b>

Пример:

<b>buat</b> <i>v</i> <b>1</b> kerjakan; lakukan; <b>2</b> bikin;<br>--<b> cendol</b>

Я хочу извлечь слова: "buat", "1", "2", "cendol"

Можете ли вы помочь мне решить мою проблему? Любой код в Excel / VBA приветствуется.

Answer 1

Это можно сделать с помощью функции рабочего листа FILTERXML, если у вас Excel 2013 +

Сначала вам нужно изменить строку в «правильно сформированный» XML, заключив ее во внешний тег и закрыв непревзойденный тег <br>:

"<t>" & $A$1 & "</br></t>"

Тогда это просто вопрос использования Xpath, который вернет все нужные теги:

FILTERXML("<t>" & $A$1 & "</br></t>","//b")

Обтекание, которое в функции INDEX позволяет извлекать подстроки по одному:

Полная формула введена в A3 и заполнена

=IFERROR(INDEX(FILTERXML("<t>" & $A$1 & "</br></t>","//b"),ROWS($1:1)),"")

Answer 2

Существует очень простой способ сделать это, используя объект HTMLDocument:

В вашем VB Editor перейдите на Tools>References и выберите Microsoft HTML Object Library.

Тогда вы можете использовать следующий код:

Sub extract()

Dim doc As New HTMLDocument 'Declare and create an object of type HTMLDocument
Dim item As HTMLObjectElement 'Declare an object of type HTMLObjectElement. We will use this to loop through a collection of HTML elements

doc.body.innerHTML = "<b>buat</b> <i>v</i> <b>1</b> kerjakan; lakukan; <b>2</b> bikin;<br>--<b> cendol</b> " 'Assign your HTML code as a string in doc body

For Each item In doc.getElementsByTagName("b") 'Loop through all the <b></b> elements in doc
    Debug.Print item.innerText 'print the text contained in <b></b> element. This will show up in your immediate window
Next item

End Sub

Answer 3

Альтернатива с использованием XML DomDocument

Анализируя строку HTML, очевидно, что используются структуры объектов документа, как в HTMLDocument или в ► XML. Вот почему я демонстрирую дальнейший подход ради полноты и в дополнение к *1000* действительному решению @ StavrosJon * (в котором используется более мягкий HTMLDocument, не требующий правильной формы, как XML):

Пример вызова

Sub ExtractViaXML()
  Dim html$, myArray()
  html = "<b>buat</b> <i>v</i> <b>1</b> kerjakan; lakukan; <b>2</b> bikin;<br>--<b> cendol</b> "
  myArray = getTokens(html, "b")                              ' assign findings to array via function getTokens()
  Debug.Print UBound(myArray) + 1 & " token(s) found: " & Join(myArray, ", ")  ' display results
End Sub

Основная функция getTokens()

Function getTokens(ByVal html$, Optional myTag$ = "b") As Variant()
' Purpose: isolate "<b>"-Tags (default value) out of html string and return found tokens as variant array
' Note:    creates temporary XML DOMDocument (late bound MSXML2 reference)
  Dim XmlString$
  XmlString = wellformed("<?xml version=""1.0"" encoding=""utf-8""?><tokens>" & html & "</tokens>")

  With CreateObject("MSXML2.DOMDocument.6.0")
      .ValidateOnParse = True: .Async = False
      If .LoadXML(XmlString) Then                              ' load xml string
          Dim myNodeList As Object
          Set myNodeList = .DocumentElement.SelectNodes(myTag) ' set node list to memory
          Dim i&, ii&, arr()
          ii = myNodeList.Length - 1                           ' calculate upper boundary of zero-based array
          If ii > -1 Then ReDim arr(ii)                        ' (re)dimension variant array arr()
          For i = 0 To ii                                      ' loop through node list
              arr(i) = myNodeList.item(i).Text                 ' assign each found text content to array
          Next i
          If ii = -1 Then arr = Array("**Nothing found**")     ' provide for zero findings
          getTokens = arr                                      ' return 0-based 1-dim array with found tokens
      Else: ShowParseError (.ParseError)                       ' optional: display possible error message
      End If
  End With
End Function

Вспомогательные функции

XML требует правильно сформированной структуры узла с открывающими и закрывающими тегами или, тогда как HTML более снисходительно относится к примеру. одиночные переводы строк (<br>). Поэтому я добавил простую функцию wellformed() в cure , которая препятствует успешной загрузке. Кроме того, я демонстрирую использование дополнительной процедуры ShowParseError для локализации (других) возможных ошибок загрузки, которые вы можете использовать в качестве дополнения к любой функции .load или .loadXML.

Function wellformed$(ByVal s$)
' Purpose: force a wellformed version of line breaks in html/xml string ("<br/>")
' Note:    unclosed tags like <br> only would prevent a successful load of the xml document
  wellformed = Replace(Replace(s, "</br>", "<br>"), "<br>", "<br/>")
End Function

Sub ShowParseError(pe As Object)
' Purpose: display possible parse error
' Note:    localizes error occurrence also by indicating position
        Dim ErrText$
        With pe
           ErrText = "Load error " & .ErrorCode & " xml file " & vbCrLf & _
           Replace(.URL, "file:///", "") & vbCrLf & vbCrLf & _
          .reason & _
          "Source Text: " & .srcText & vbCrLf & vbCrLf & _
          "Line No.:    " & .Line & vbCrLf & _
          "Line Pos.: " & .linepos & vbCrLf & _
          "File Pos.:  " & .filepos & vbCrLf & vbCrLf
        End With
        MsgBox ErrText, vbExclamation
End Sub

Answer 4

Попробуйте это

Sub Test()
Dim objReg      As Object
Dim objMatches  As Object
Dim match       As Object
Dim s           As String
Dim i           As Integer

s = "<b>buat</b> <i>v</i> <b>1</b> kerjakan; lakukan; <b>2</b> bikin;<br>--<b> cendol</b> "
Set objReg = CreateObject("VBScript.RegExp")

With objReg
    .IgnoreCase = False
    .Global = True
    .Pattern = "<b>(.*?)<\/b>"
    Set objMatches = .Execute(s)
End With

For Each match In objMatches
    For i = 0 To match.Submatches.Count - 1
        Debug.Print Trim(match.Submatches.item(i))
    Next i
Next match

Set objReg = Nothing
End Sub

Answer 5

Я пробовал что-то другое, с разбиением, объединением и повторным разбиением и циклическим преобразованием массиваЯ набрал текст <b>buat</b> <i>v</i> <b>1</b> kerjakan; lakukan; <b>2</b> bikin;<br>--<b> cendol</b> в ячейку A1:

Sub Macro1()
Dim MyWords As Variant
Dim i As Long
Dim MyDelimiter As String
Dim MyLen As Byte

MyDelimiter = "||" 'Choose 1 not common delimiter
MyLen = Len(MyDelimiter)

MyWords = Split(Join(Split(Range("A1").Value, "<b>"), MyDelimiter), "</b>")

For i = 0 To UBound(MyWords) Step 1
    Debug.Print Mid(MyWords(i), InStr(1, MyWords(i), MyDelimiter) + MyLen, 99) 'Increase 99 if you are sure there will be longer texts between tags <b>..</b>
Next i

Erase MyWords
End Sub

Я получил это:

Answer 6

Я пытался смоделировать это на Excel. пожалуйста, проверьте мой пример решения ниже.

Sub test()

    Dim testString As String
    Dim startPos As Integer
    Dim endPos As Integer
    Dim resultString As String
    Dim str As String

    testString = "<b>buat</b> <i>v</i> <b>1</b> kerjakan; lakukan; <b>2</b> bikin;<br>--<b> cendol</b>"


    'get the position of start tag
    startPos = InStr(1, testString, "<b>") + 3

    'get the position of end tag
    endPos = InStr(startPos, testString, "</b>")


    Do While Len(testString) > 1

        'check if the start pos and end pos is correct
        If startPos > 0 And endPos > startPos Then

            'get the value in between the start tag and end tag
             str = Mid(testString, startPos, endPos - startPos)

             resultString = resultString + str + ","

             'remove the value retrieved from the original string
             testString = Mid(testString, endPos + 4)

             startPos = InStr(1, testString, "<b>") + 3
             endPos = InStr(startPos, testString, "</b>")

        End If

    Loop

End Sub