VBA Loop через строку до пустого и переменного использования

Question

Код ниже - это скребок таблицы веб-страниц, который я использую, и он прекрасно работает.В настоящее время он открывает только гиперссылку, которая находится в местоположении 'L4', используя .Open "GET", Range("L4"), False

Sub ImportData()

'Objects
Dim htm As Object
Dim Tr As Object
Dim Td As Object
Dim Tab1 As Object

'Create HTMLFile Object
Set HTML_Content = CreateObject("htmlfile")

'Get the WebPage Content to HTMLFile Object

On Error GoTo Error

With CreateObject("msxml2.xmlhttp")
    .Open "GET", Range("L4"), False 'Cell that contains hyperlink
    .send
    HTML_Content.body.innerHTML = .responseText
End With

On Error GoTo Error

'Add New Worksheet
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:= _
         ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = "ESTIMATE"

'Set table variables
Column_Num_To_Start = 1
iRow = 2
iCol = Column_Num_To_Start
iTable = 0

'Loop Through Each Table and Download it to Excel in Proper Format
For Each Tab1 In HTML_Content.getElementsByTagName("table")
    With HTML_Content.getElementsByTagName("table")(iTable)
        For Each Tr In .Rows
            For Each Td In Tr.Cells
                Sheets(2).Cells(iRow, iCol).Select
                Sheets(2).Cells(iRow, iCol) = Td.innerText
                iCol = iCol + 1
            Next Td
            iCol = Column_Num_To_Start
            iRow = iRow + 1
        Next Tr
    End With
    iTable = iTable + 1
    iCol = Column_Num_To_Start
    iRow = iRow + 1
Next Tab1
 'Success

'Loop to find authorised hours string
Dim rng1 As Range
Dim strSearch As String
strSearch = "Hours"
Set rng1 = Range("A:A").Find(strSearch, , xlValues, xlWhole)
If Not rng1 Is Nothing Then
'Add Value to Sheet1

Sheets(1).Range("E4").Value = rng1.Offset(0, 1)
Else

Sheets(1).Range("E4").Value = 0
End If

strSearch = "Actual Hours"
Set rng1 = Range("A:A").Find(strSearch, , xlValues, xlWhole)
If Not rng1 Is Nothing Then
Sheets(1).Range("D4").Value = rng1.Offset(0, 1)
Else
  Sheets(1).Range("D4").Value = 0
'Move on to next
End If

strSearch = "Name"
Set rng1 = Range("A:A").Find(strSearch, , xlValues, xlWhole)
If Not rng1 Is Nothing Then
Sheets(1).Range("J4").Value = rng1.Offset(0, 1)
Else

Sheets(1).Range("J4").Value = "NULL"
End If

'Scrape Description
Dim desc As String
HTML_Content.getElementsByTagName ("div")
desc = HTML_Content.getElementsByTagName("p")(0).innerText

Sheets(1).Range("K4").Value = desc

'Keep Sheet 1 Open
Sheets(1).Activate

'Delete ESTIMATE Sheet
Application.DisplayAlerts = False
Sheets(2).Delete
Application.DisplayAlerts = True

Error:

End Sub

Начальная строка гиперссылки - L4, как я могу сделать цикл, который циклически перебирает все ссылки, расположенные в Lстолбец и запускает этот скрипт для каждой гиперссылки, которая находится в столбце L?Как бы я сделал переменную для того, чтобы Range знал, какая строка обрабатывается в настоящее время?

Могу ли я поместить свой код во что-то вроде этого:

For Each i In Sheet1.Range("L4:L200")

' code here

Next i

Любая помощь очень ценится,спасибо.

Answer 1

изменить

Sub ImportData()
...
.Open "GET", Range("L4"), False 'Cell that contains hyperlink
...

на

Sub ImportData(urlToOpen as string)
...
.Open "GET", urlToOpen, False 'Cell that contains hyperlink
...

и добавить процедуру вызова:

Sub CallRangeL_Urls
    For Each i In Sheet1.Range("L4:L200")
        ' code here
        call ImportData(i)
    Next i
end sub

ОБНОВЛЕНИЕ 1

Чтобы получить данные из процедуры, вы можете либо отправить их обратно в основную процедуру, либо подготовить место до вызова процедуры:

либо:

Sub CallRangeL_Urls
    For Each i In Sheet1.Range("L4:L200")
        ' code here
        call ImportData(i, returnValue)
        i.offset(0,1).value = returnValue
    Next i
end sub

Sub ImportData(urlToOpen as string, returnValue as string)
...
'returnValue = Data you want to give back
returnValue = DataSource...(I didn't read your code again ;-)
...

или:

Sub CallRangeL_Urls
    Dim targetRange as Range
    For Each i In Sheet1.Range("L4:L200")
        ' code here
        sheets.add after:=sheets(1)

        'set a link on the sheet
        Range("A1").value = i
        Set targetRange = Range("A3")
        call ImportData(i, targetRange)
    Next i
end sub

Sub ImportData(urlToOpen as string, target as range)
...
'Save whatever data to the new sheet
target.offset(0,0).value = datavalue1        'Range("A3")
target.offset(1,0).value = datavalue1        'Range("A4")
target.offset(2,0).value = datavalue1        'Range("A5")
...

---

ОБНОВЛЕНИЕ 2

ОБНОВЛЕНИЕ 2: отдельные элементы данных (рабочий пример)

Option Explicit

Sub CallRangeL_Urls()
    Dim iCell As Range
    Dim Sheet1 As Worksheet
    Dim returnValue As String

    Set Sheet1 = ActiveSheet

    For Each iCell In Sheet1.Range("L4:L4")
        ' code here
        Debug.Print "url: "; iCell.Value
        Call ImportData(iCell.Value, returnValue)
        iCell.Offset(0, 1).Value = returnValue

        Debug.Print returnValue
    Next iCell
End Sub

Sub ImportData(urlToOpen As String, ByRef returnValue As String)

'...
'returnValue = Data you want to give back
returnValue = "This is the data we get back from yourUrl: " & urlToOpen & " - DATA/DATA/DATA"  'DataSource...(I didn't read your code again ;-)
End Sub

Непосредственное окно:

url: www.google.de
This is the data we get back from yourUrl: www.google.de - DATA/DATA/DATA

---

ОБНОВЛЕНИЕ 2: данные на листе (ах) результатов (рабочий пример)

Option Explicit

Sub CallRangeL_Urls()
    Dim iCell As Range
    Dim targetRange As Range
    Dim Sheet1 As Worksheet

    Set Sheet1 = ActiveSheet
    For Each iCell In Sheet1.Range("L4:L4")
        'create a new "RESULTS" sheets
        Sheets.Add after:=Sheets(1)
        Debug.Print "New sheet created: " & ActiveSheet.Name

        'set a link on the sheet
        Range("A1").Value = iCell.Value     'leave a copy of the url on the sheet as a reference
        Set targetRange = Range("A3")       'here we want to get the results
        Call ImportData(iCell.Value, targetRange)
    Next iCell
End Sub

Sub ImportData(urlToOpen As String, target As Range)
Dim datavalue1, datavalue2, datavalue3
'...
datavalue1 = "data value 1"
datavalue2 = "data value 2"
datavalue3 = "data value 3"

'Save whatever data to the new sheet
target.Offset(0, 0).Value = datavalue1       'Range("A3")
target.Offset(1, 0).Value = datavalue2       'Range("A4")
target.Offset(2, 0).Value = datavalue3       'Range("A5")

Debug.Print "datavalues stored on sheet: " & target.Parent.Name
'...
End Sub

Непосредственное окно:

New sheet created: Sheet2
datavalues stored on sheet: Sheet2