VBA 用于复制多个网页并粘贴到单独的 Excel 工作表中

Question

我有一个在 Excel 文件中包含公式创建链接的文件。我已经为

创建了按钮和宏

1. 将公式转换为链接
2. 在 Internet Explorer 中打开所有链接
3. 从单个链接复制单个网页并粘贴到单独工作表上的 Excel 中

我需要的是一种循环第三个宏的方法，以从每个链接复制网页的内容，而不仅仅是第一个链接，并将每个链接的每个网页内容粘贴到同一工作簿中自己的工作表中。

Sub OpenHyperLinks()
'Update 20141124
Dim xHyperlink As Hyperlink
Dim WorkRng As Range
On Error Resume Next
xTitleId = "KutoolsforExcel"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address,  Type:=8)
For Each xHyperlink In WorkRng.Hyperlinks
    xHyperlink.Follow
Next


End Sub
Sub HyperAdd()

'Converts each text hyperlink selected into a working hyperlink

For Each xCell In Selection
    ActiveSheet.Hyperlinks.Add Anchor:=xCell, Address:=xCell.Formula
Next xCell

End Sub
Sub pasteMyWebP()
Dim wb As Workbook, ws As Worksheet
Dim IE As Object

Const strURL As String = "https://www.aiproducts.com/dealer              /OrderDetl.htm?OrderNumber=10110630&InvoiceNumber=8042869"


Set wb = Workbooks.Add(xlWBATWorksheet)
Set ws = wb.Sheets(1)

Set IE = CreateObject("InternetExplorer.Application")

IE.Visible = True
IE.Navigate strURL

Do While IE.ReadyState <> 4
DoEvents
Loop

IE.ExecWB 17, 2
IE.ExecWB 12, 2

ActiveSheet.Paste Range("a1")
IE.Visible = False
End Sub

Answer 1

试试下面的代码。根据您的代码，这有点笼统，但是概念就在那里。您可能需要修改一些内容。此外，您无需将公式转换为超链接。

Sub ScrapeWebPagetoNewSheet()

Dim wsLinks As Worksheet
Set wsLinks = Worksheets("Links") 'change name to the correct worksheet
Dim rngLinks As Range, rngLink As Range
Set rngLinks = ws.Range("A1:A10") 'change range to correct range

Dim IE As Object
Set IE = CreateObject("InternetExplorer.Application") 'creating it here so it remains open

For Each rngLink In rngLinks
    pasteMyWebP rngLink.Formula, ThisWorkbook, IE
Next rngLink

IE.Quit

End Sub

Sub pasteMyWebP(sURL As String, wb As Workbook, IE As Object)

    Dim wsPaste As Worksheet
    Set wsPaste = wb.Sheets.Add(After:=Sheets(wb.Sheets.Count))

    With IE

        .Visible = True
        .Navigate strURL

        Do While .ReadyState <> 4
            DoEvents
        Loop

        .ExecWB 17, 2
        .ExecWB 12, 2

        wsPaste.Paste Range("a1")

        .Visible = False

    End With

End Sub