VBA遍历行直到空白和变量使用

Question

下面的代码是我正在使用的网页表格抓取工具，效果很好。 当前仅使用.Open "GET", Range("L4"), False 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