Question

我在excel文件中有一个带有公式创建链接的文件。我已经创建了按钮和宏

将公式转换为链接
打开Internet Explorer中的所有链接
从单个链接复制单个网页，然后将其粘贴到另一张表格中的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

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

1 个答案: