vba - 跟随链接并将表格下载到新工作表中的宏

Question

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

路易斯安那州 DNR 对该州钻探的每一口油井都保留着惊人的记录，所有这些记录都位于 www.Sonris.com 上。这些记录的一部分是每口井的生产记录。我想创建一个宏，它遵循给定的 url 并下载在 URL 上找到的表(也称为生产记录)。下载文件后，我希望它将表放入新工作表中，然后根据井名称命名该工作表。

我已经玩弄了从网络函数检索数据，但是我无法使该函数足够动态。我需要代码来复制单元格中找到的超链接数据。目前，代码仅遵循我在录制宏时复制和粘贴的超链接。

如有任何帮助，我们将不胜感激

真诚的，约西亚

下面是生成的代码；

    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 和文件 ► 打开即可打开充满表格的网页。我将在此处发布代码，但我还将提供一个工作示例工作簿的链接，该工作簿大约需要 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 标识符列表位于从第 2 列开始的 WSN 工作表中。通过点击 Alt+F8 打开宏来运行宏宏对话框和运行Gather_Well_Data宏。完成后，您将拥有一个工作簿，其中包含由 WSN 识别的工作表，如下所示。

         

示例工作簿位于我的公共(public) DropBox 上:

LA_WSN_Data.xlsb