Vba 宏，该宏跟随链接并将表下载到新工作表中

我是路易斯安那州一家小型石油公司的地质学家。我是我们技术部门的一员，不幸的是，我在编码方面的经验非常有限。我过去使用过非常基本的vba编码，但我在日常工作中没有这么多代码，所以我已经忘记了大部分内容

路易斯安那dnr保存着该州每一口钻井的惊人记录，所有这些记录都位于www.Sonris.com。这些记录的一部分是每口井的生产记录。我想创建一个宏，它遵循给定的url并下载url上的表（也称为生产记录）。下载完文件后，我想让它把表放在一张新的表中，然后根据井名给这张表命名

我已经玩弄了从web检索数据的功能，但是我无法使该功能具有足够的动态性。我需要代码来复制在单元格中找到的超链接数据。目前，代码只是跟随我在录制宏时复制和粘贴的超链接

任何帮助都将不胜感激

真诚地， 约西亚

下面是生成的代码

    Sub Macro2()
'
'     Macro2 Macro
' attempt with multiple well to look at code instead of 1 well
'

'
    Range("E27").Select
    ActiveWorkbook.Worksheets.Add
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://sonlite.dnr.state.la.us/sundown/cart_prod/cart_con_wellinfo2?p_WSN=159392" _
        , Destination:=Range("$A$1"))
        .Name = "cart_con_wellinfo2?p_WSN=159392"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = "1,11"
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    Sheets("Sheet1").Select
End Sub

---

使用所有可用于清除外部数据的方法，许多用户忘记了，您可以打开一个充满表格的网页，而只需要一个有效的URL和文件► 打开我在这里发布代码，但我还将提供一个指向工作示例工作簿的链接，该工作簿花了~2分钟从14个按顺序编号的WSN（web序列号）页面收集完整的网页数据。您自己的结果可能会有所不同

Option Explicit

Public Const csURL As String = "http://sonlite.dnr.state.la.us/sundown/cart_prod/cart_con_wellinfo2?p_WSN=×WSN×"

Sub Gather_Well_Data()
    Dim rw As Long, lr As Long, w As Long, wsn As String, wb As Workbook
    On Error GoTo Fìn
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With ThisWorkbook.Sheets("WSNs")
        lr = .Cells(Rows.Count, 1).End(xlUp).Row
        For rw = 2 To lr
            .Cells(rw, 2) = 0
            For w = 1 To .Parent.Sheets.Count
                If .Parent.Sheets(w).Name = CStr(.Cells(rw, 1).Value) Then
                    .Parent.Sheets(w).Delete
                    Exit For
                End If
            Next w
            wsn = Replace(csURL, "×WSN×", .Cells(rw, 1).Value)
            Set wb = Workbooks.Open(Filename:=wsn, ReadOnly:=True, addtomru:=False)
            wb.Sheets(1).Range("A1:A3").Font.Size = 12
            wb.Sheets(1).Copy After:=.Parent.Sheets(.Parent.Sheets.Count)
            .Parent.Sheets(.Parent.Sheets.Count).Name = .Cells(rw, 1).Value
            wb.Close savechanges:=False
            Set wb = Nothing
            .Cells(rw, 2) = 1
            Application.ScreenUpdating = True
            Application.ScreenUpdating = False
            .Parent.Save
        Next rw
        .Activate
    End With
Fìn:
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

WSN标识符列表位于从第2列开始的WSN工作表中。通过点击Alt+F8来运行宏，以打开“宏”对话框，然后运行“收集数据”宏。完成后，您将拥有一个工作簿，其中包含由WSN识别的工作表，如下所示

示例工作簿位于我的公共DropBox上，网址为：

---

为了利用@Jeeped awesome解决方案，我添加了要删除的格式，只保留了LeaseUnit/Well/Production信息。这假设套管表始终遵循生产表

Option Explicit

Public Const csURL As String = "http://sonlite.dnr.state.la.us/sundown/cart_prod/cart_con_wellinfo2?p_WSN=×WSN×"

Sub Gather_Well_Data()
    Dim rw As Long, lr As Long, w As Long, wsn As String, wb As Workbook, frow As String, lrow As String
    On Error GoTo Fìn
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False



    With ThisWorkbook.Sheets("WSNs")
        lr = .Cells(Rows.Count, 1).End(xlUp).Row
        For rw = 2 To lr
            .Cells(rw, 2) = 0
            For w = 1 To .Parent.Sheets.Count
                If .Parent.Sheets(w).Name = CStr(.Cells(rw, 1).Value) Then
                    .Parent.Sheets(w).Delete
                    Exit For
                End If
            Next w
            wsn = Replace(csURL, "×WSN×", .Cells(rw, 1).Value)
            Set wb = Workbooks.Open(Filename:=wsn, ReadOnly:=True, addtomru:=False)

            frow = Application.WorksheetFunction.Match("LEASE\UNIT\WELL PRODUCTION", Range("A:A"), 0)
            lrow = Application.WorksheetFunction.Match("Casing", Range("A:A"), 0)
            lrow = lrow - 1
            frow = "A" & frow
            lrow = "K" & lrow
            Range(frow, lrow).Cut Range("Q1")
            Columns("A:P").Select
            Selection.Delete Shift:=xlToLeft
            Cells.EntireColumn.AutoFit

            wb.Sheets(1).Range("A1:A3").Font.Size = 12
            wb.Sheets(1).Copy After:=.Parent.Sheets(.Parent.Sheets.Count)
            .Parent.Sheets(.Parent.Sheets.Count).Name = .Cells(rw, 1).Value
            wb.Close savechanges:=False
            Set wb = Nothing
            .Cells(rw, 2) = 1
            Application.ScreenUpdating = True
            Application.ScreenUpdating = False
            .Parent.Save
        Next rw
        .Activate
    End With
Fìn:
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

---

吉普德的方法岩石+1

您还可以针对API发出

POST

请求，并按如下方式写出所有表

注意：我正在一个接一个地写每个井信息，但很容易就可以放一张表。在下一个API调用之前添加行，只需确保每次数据写出都使用activesheet即可

Option Explicit
Public Sub GetWellInfo()
    Dim ws As Worksheet, page As HTMLDocument, targetTable As HTMLTable, apiNumbers(), currNumber As Long
    Const PARAM1 As String = "p_apinum"
    Const BASESTRING As String = "http://sonlite.dnr.state.la.us/sundown/cart_prod/"
    apiNumbers = Array(1708300502, 1708300503)

    Application.ScreenUpdating = False
    Set ws = ThisWorkbook.Worksheets("Sheet1")

    With ws
        .Cells.ClearContents
        For currNumber = LBound(apiNumbers) To UBound(apiNumbers)
            Set page = GetPage(BASESTRING & "cart_con_wellapi2", apiNumbers(currNumber), PARAM1)
            Set page = GetPage(BASESTRING & GetNextURL(page.body.innerHTML))
            Dim allTables As Object
            Set allTables = page.getElementsByTagName("table")

            For Each targetTable In allTables
                AddHeaders targetTable, GetLastRow(ws, 1) + 2, ws
                WriteTables targetTable, GetLastRow(ws, 1), ws
            Next targetTable

        Next currNumber
    End With
    Application.ScreenUpdating = True
End Sub

Public Function GetPage(ByVal url As String, Optional ByVal apiNumber As Long, Optional ByVal paramN As String = vbNullString) As HTMLDocument
    Dim objHTTP As Object, html As New HTMLDocument

    Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")

    Dim sBody As String
    If Not paramN = vbNullString Then sBody = paramN & "=" & apiNumber
    With objHTTP
        .SetTimeouts 10000, 10000, 10000, 10000
        .Open "POST", url, False
        .setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
        .setRequestHeader "Content-type", "application/x-www-form-urlencoded"
        On Error Resume Next
        .send (sBody)
        If Err.Number = 0 Then
            If .Status = "200" Then
                html.body.innerHTML = .responseText
                Set GetPage = html
            Else
                Debug.Print "HTTP " & .Status & " " & .statusText
                Exit Function
            End If
        Else
            Debug.Print "Error " & Err.Number & " " & Err.Source & " " & Err.Description
            Exit Function
        End If
        On Error GoTo 0
    End With

End Function

Public Function GetNextURL(ByVal inputString As String)
    GetNextURL = Replace$(Replace$(Split(Split(inputString, "href=")(1), ">")(0), Chr$(34), vbNullString), "about:", vbNullString)
End Function

Public Sub AddHeaders(ByVal hTable As Object, ByVal startRow As Long, ByVal ws As Worksheet)
    Dim headers As Object, header As Object, columnCounter As Long
    Set headers = hTable.getElementsByTagName("th")
    For Each header In headers
        columnCounter = columnCounter + 1
        ws.Cells(startRow, columnCounter) = header.innerText
    Next header
End Sub

Public Sub WriteTables(ByVal hTable As HTMLTable, Optional ByVal startRow As Long = 1, Optional ByRef ws As Worksheet)
    If ws Is Nothing Then Set ws = ActiveSheet

    Dim tRow As Object, tCell As Object, tr As Object, td As Object, r As Long, c As Long
    r = startRow
    With ActiveSheet
        Set tRow = hTable.getElementsByTagName("tr")
        For Each tr In tRow
            Set tCell = tr.getElementsByTagName("td")
            For Each td In tCell
                .Cells(r, c).Value = td.innerText
                c = c + 1
            Next td
            r = r + 1:  c = 1
        Next tr
    End With
End Sub

---

您希望检索多少个井，WSN编号在哪里，您希望所有的表还是只是一个选择？理想情况下，我希望对整个油田进行此操作（因此在300个井的范围内）。我只想在表的选择中使用1个表。什么是无线传感器网络号？我猜无线传感器网络是井的序列号，如

。？p_WSN=159392

。啊，是的，我道歉。我以为那是一个密码。那代表井的序列号。序列号位于工作表的一列中。到目前为止，我还没有尝试在代码中使用它。您上面的代码当前运行时做什么？它是否能成功地用于特定的

WSN=159392

？非常感谢您为此所做的所有工作。我有一个后续问题。有没有办法只从网页下载一个表格而不是整个油井报告？我希望自动下载生产数据（网页上的leaseunit/well生产表），然后将其插入格式化的工作簿中，以自动计算我公司感兴趣的一些值。@JosiahHulsey-是的，这很可能与Excel中的任何一个数据一起使用► 获取外部数据► 从网页、Internet Explorer对象甚至Msxml.DOMDocument dom对象（TBH），收集300个页面并删除所有不需要的内容或将实际需要的内容整理到一个大型数据表或数据库中会更容易。