Public Function getTextOnly(ByVal fromText As String) As String
Dim pReg As Object
Set pReg = CreateObject("VBScript.RegExp")
pReg.Pattern = "<[^<>]+>"
pReg.Global = True
getTextOnly = pReg.Replace(fromText, "")
End Function
Андрей VG, после функции остались и переносы, которые убираются ПЕЧСИМВ - я это имел в виду. В любом случае еще раз искренне благодарю вас. Действительно помогло.
Где-то на форуме было что-то похожее, не помню где, макрос остался в памяти:
Код
Option Explicit
Sub abc_xyz()
Dim ieap As Object: Set ieap = CreateObject("InternetExplorer.Application")
ieap.Navigate "about:blank"
Dim r&: r = 2
With Sheets("List1")
Do Until .Range("A" & r).Value = ""
ieap.document.body.InnerHTML = .Range("A" & r).Value
ieap.ExecWB 17, 0: ieap.ExecWB 12, 2
ActiveSheet.Paste Destination:=.Range("C" & r)
Application.CutCopyMode = False
r = r + 1
Loop
End With
ieap.Quit: Set ieap = Nothing
End Sub
Можно так очистить (код встроен в приложенную книгу, нужно нажать кнопку Run)
Код
Function HtmlToText(Html) As String
' ZVI:2019-07-06 функция выделения текста из HTML
' https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&TID=118648
Static objDOM As Object
If objDOM Is Nothing Then Set objDOM = CreateObject("htmlfile")
With objDOM
.Write Html
HtmlToText = Trim(Replace(.Body.innerText, vbCrLf, " "))
.Close
End With
End Function
Sub ClearHtml()
' Обработка диапазона A2:A...
Dim a(), i As Long, rng As Range
Set rng = Range("A2", Cells(Rows.Count, "A").End(xlUp))
a() = rng.Value
For i = 1 To UBound(a)
a(i, 1) = HtmlToText(a(i, 1))
Next
Application.ScreenUpdating = False
With rng.EntireRow.Columns("C").Resize(UBound(a))
.Value = a()
.WrapText = False
.ShrinkToFit = False
End With
Application.ScreenUpdating = True
End Sub