如何使此 vba 代码从 Internet 检索 2 个表而不是 1 个表

Question

我是一名从事石油和天然气业务的地质学家。我还负责我们所有的技术。在过去的几周里，我一直在设计一个与路易斯安那州自然资源部网站接口的宏，以便创建一个自动编译生产信息的程序。该网站提供了巨大的帮助，用户提供的建议非常宝贵。我再次陷入困境，需要一些帮助。

在介绍我需要的内容之前，我只想感谢创建此代码的用户@Jeeped 和@mrbungle。它就像我要求的那样工作并且取得了巨大的成功。

代码的工作方式是，代码获取油井的序列号（在 A 列中），然后转到路易斯安那州 DNR 网站，并使用该序列号将生产报告下载到新工作表中.这个新工作表是根据第一个工作表的 C 列中的值命名的。

目前，编写的代码是检索整个报告，然后删除所有信息，除了一个我感兴趣的table。

我现在想保留 2 个 table，而不是 1 个。我不知道该怎么做。我试图添加一个 frow2 和 lrow2 变量（相当于我想要保留的第二个 table ）但是由于 cut 函数，只有较低的 table 会被保留，因为 cut 函数会剪切所有数据高于某一点。我认为答案在于如何表达 cut 函数。不过我不知道该怎么做。

剪切功能目前的工作方式是剪切下载表中某些 table 名称上方和下方的所有数据

我想保留的 table 是（按顺序）"Wells" 和 "Perforations" table

这是井的序列号，以备您测试程序时使用：57711

代码如下

Option Explicit

Public Const csURL As String =       "http://sonlite.dnr.state.la.us/sundown/cart_prod/cart_con_wellinfo2?p_WSN=×WSN×"
Sub Gather_Perforations_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 Resume Next
If Err.Number <> 0 Then MsgBox "Exception occured: " & Err.Decscription

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("Perforations", Range("A:A"), 0)
        lrow = Application.WorksheetFunction.Match("Well Tests", Range("A:A"), 0)
        lrow = lrow - 1
        frow = "A" & frow
        lrow = "F" & 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, 3).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 = 真 Application.ScreenUpdating = 正确结束子

如果我能解释得更好，请告诉我。

Answer 1

Option Explicit

Public Const csURL As String = "http://sonlite.dnr.state.la.us/sundown/cart_prod/cart_con_wellinfo2?p_WSN=×WSN×"
Sub Gather_Perforations_Data_save_api_row()
Dim rw As Long, lr As Long, w As Long, wsn As String, wb As Workbook, frow As String, lrow As String, lrow2 As String, frow2 As String

On Error Resume Next
If Err.Number <> 0 Then MsgBox "Exception occured: " & Err.Decscription

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("Wells", Range("A:A"), 0)
        lrow = Application.WorksheetFunction.Match("Well Tests", Range("A:A"), 0)
        lrow = lrow - 1
        frow = "A" & frow
        lrow = "O" & lrow
        Range(frow, lrow).Cut Range("Q1")
        Columns("A:P").Select
        Selection.Delete Shift:=xlToLeft
        Cells.EntireColumn.AutoFit


        frow2 = Application.WorksheetFunction.Match("Well Surface Coordinates", Range("A:A"), 0)
        lrow2 = Application.WorksheetFunction.Match("Perforations", Range("A:A"), 0)
        lrow2 = lrow2 - 1
        frow2 = "A" & frow2
        lrow2 = "P" & lrow2
        Range(frow2, lrow2).Delete




        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, 3).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

如何使此 vba 代码从 Internet 检索 2 个表而不是 1 个表

How to make this vba code retrieve 2 tables instead of 1 from the internet

excel

vba