очистка веб-страниц с использованием vba без повторного запуска каждого ввода в заданном диапазоне - PullRequest
Новая
       21

очистка веб-страниц с использованием vba без повторного запуска каждого ввода в заданном диапазоне

0 голосов
/ 20 апреля 2020

Я решаю следующую проблему: я хочу очистить заголовок веб-сайта, когда ссылка вставлена ​​в столбец A, и поместить это значение в соответствующую ячейку (рядом с ней) в столбце B. Кажется, что проблема заключается в том, что после вставки веб-сайт в столбце A, код перезапускает весь список со столбца A2 до «последней строки», как определено в коде. Есть ли способ изменить столбец B только после изменения одного столбца A? Т.е., если я вставлю ссылку в столбец A36, я получу заголовок в B36, независимо от того, находится ли ячейка в середине используемого диапазона или в самом низу (то есть затрагивается только эта ячейка). Я бы хотела использовать это без необходимости повторного запуска нескольких входов в текущем состоянии; (т. е. l oop "для i = 2 до последней строки")? Кроме того, я хотел бы изменить нижеприведенное значение из модульного макроса, то есть подчиненное к частному подчиненному, реагирующему на изменение (то есть функцию пересечения), где «цель» - любая ячейка из диапазона A: A. Большое спасибо!

enter code here

Sub get_title_header()

Dim wb As Object
Dim doc As Object
Dim sURL As String
Dim lastrow As Long
lastrow = Sheet1.Cells(Rows.Count, "A").End(xlUp).row

For i = 2 To lastrow
Set wb = CreateObject("internetExplorer.Application")
sURL = Cells(i, 1)

wb.navigate sURL
wb.Visible = False

While wb.Busy
DoEvents
Wend

''HTML document
Set doc = wb.document

Cells(i, 2) = doc.Title

On Error GoTo err_clear
Cells(i, 3) = doc.GetElementsByTagName("h1")(0).innerText
err_clear:
If Err <> 0 Then
Err.Clear
Resume Next
End If
wb.Quit
Range(Cells(i, 1), Cells(i, 3)).Columns.AutoFit
Next i

End Sub

1 Ответ

2 голосов
/ 20 апреля 2020

Поместите код в событие изменения рабочего листа (щелкните правой кнопкой мыши вкладку листа >> Просмотреть код >> Вставьте код) 

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ie As Object, doc As Object, sURL As String
If Target.Cells.CountLarge > 1 Then Exit Sub
If Target.Column = 1 Then
    Set ie = CreateObject("internetExplorer.Application")
    sURL = Target.Value

    With ie
        .navigate sURL
        .Visible = False
        While .Busy: DoEvents: Wend
        Set doc = .document
    End With

    Target.Offset(, 1).Value = doc.Title
    On Error GoTo errClear
    Target.Offset(, 2).Value = doc.getElementsByTagName("h1")(0).innerText

errClear:
    If Err <> 0 Then Err.Clear: Resume Next
    ie.Quit
    Set ie = Nothing
    Application.Wait Now + TimeValue("00:00:03")
    Columns("A:C").AutoFit
End If
End Sub
...