跟随链接的宏，并将表下载到新表中

Question

我是在路易斯安那州一家小型石油公司工作的地质学家。我组成了我们的技术部门，不幸的是，我在编码方面的经验非常有限。过去，我使用过非常基本的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

Answer 1

使用所有可用的清除外部数据的方法，许多用户忘记了您可以打开一个充满表的网页，仅包含有效的URL和File？打开。我将代码发布在这里，但是我还将提供一个工作样本工作簿的链接，该工作簿花了大约2分钟的时间来从14个顺序编号的WSN（网络序列号）页面收集完整的网页数据。您自己的结果可能会有所不同。

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标识符的列表在WSN工作表中，从第2列开始。点击Alt+ F8打开“ 宏”对话框和Gather_Well_Data宏Run，运行宏。完成后，您将获得一个工作簿，其中包含由WSN标识的工作表，如下所示。

         

示例工作簿在我的公共DropBox上，位于：

LA_WSN_Data.xlsb