Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Выделение текста из HTML (удалить из ячейки лишнее)
 
Одна замечательная программа, которую нельзя называть, выгружает данные в excel с бесполезной чепухой типа:

<br></p><table width="100%" style="border-collapse: collapse; mso-table-layout-alt: fixed; mso-yfti-tbllook: 1184; mso-padding-alt: 0cm 5.4pt 0cm 5.4pt;" border="0" cellspacing="0" cellpadding="0">
<tbody><tr style="mso-yfti-irow: 0; mso-yfti-firstrow: yes; mso-yfti-lastrow: yes;">
 <td width="358" valign="top" style="padding: 0cm 5.4pt; border: #000000; border-image: none; width: 268.45pt; background-color: transparent;">
 <p align="left" style="margin: 0cm 0cm 0pt; text-align: left; line-height: 12pt;"><span style="color: black; font-size: 12pt; mso-fareast-font-family: Calibri;">

Учитывая что программу которую нельзя назвать не исправить то как можно почистить результат ее выгрузки?

UPD: под "почистить" понимается - информация на русском языке, без служебных символов.  
Изменено: Ri Yu - 6 июл 2019 15:20:15
чтоб дело мастера боялось, он знает много страшных слов.
 
Цитата
Ri Yu написал: как можно почистить результат ее выгрузки?  
Выделить столбец А - нажать кнопку Delete
Согласие есть продукт при полном непротивлении сторон.
 
Цитата
Ri Yu написал: UPD: под "почистить" понимается - информация на русском языке, без служебных символов.
Лучше в файле-примере покажите. На одном листе Как есть, на другом Как надо. Вручную, несколько строк
Согласие есть продукт при полном непротивлении сторон.
 
Доброе время суток.
Можно такой udf-функцией.
Код
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
 
Sanja, прилагаю
чтоб дело мастера боялось, он знает много страшных слов.
 
Андрей VG, коллега, я в восторге! Очень элегантное решение!
И хоть почищено не все, но это большой прорыв в решении моей задачи!

Очень благодарен!
чтоб дело мастера боялось, он знает много страшных слов.
 
Цитата
Ri Yu написал:
И хоть почищено не все
А пример, в качестве доказательства привести можете? Или вы тоже сторонник бездоказательных утверждений - я так вижу?
 
Андрей VG, после функции остались &nbsp; и переносы, которые убираются ПЕЧСИМВ - я это имел в виду.
В любом случае еще раз искренне благодарю вас. Действительно помогло.  
чтоб дело мастера боялось, он знает много страшных слов.
 
Цитата
Ri Yu написал:
переносы, которые убираются ПЕЧСИМВ
a "&nbsp;" - с помощью ПОДСТАВИТЬ.
Владимир
 
Где-то на форуме было что-то похожее, не помню где, макрос остался в памяти:
Код
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
Изменено: ZVI - 6 июл 2019 20:20:36 (Обновил код для удаления vbCrLf)
Страницы: 1
Читают тему (гостей: 2)
Наверх