更新1

Question

下面的代码是我正在使用的网页表格抓取工具，并且效果很好。当前，它仅使用.Open "GET", Range("L4"), False

打开位于位置“ L4”的超链接。

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

更改

Point3D

进入

Point2D

并添加一个调用过程：

Point3D

更新1

要从过程中获取数据，您可以将其发送回主过程中，也可以在调用过程之前准备好位置：

要么：

Point2D

或：

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

更新2

更新2：单个数据项（工作示例）

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

更新2：结果表上的数据（工作示例）

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")
...

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

1 个答案:

更新1

更新2