Question

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

在我进入我需要的东西之前，我只想归功于用户@Jeeped和@mrbungle来创建这个代码。它就像我问的那样有效，并取得了巨大的成功。

代码的工作方式是代码采用油井的序列号（在A栏中）然后转到路易斯安那州DNR网站并使用此序列号将生产报告下载到新的工作表中。此新工作表基于第一个工作表的C列中的值命名。

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

我想现在保留2个表而不是1.我无法弄清楚如何做到这一点。我试图添加一个frow2和lrow2变量（等同于我想保留的第二个表）但是由于cut函数，只有下表会被保留，因为cut函数会将所有数据都切换到某一点以上。我认为答案在于如何说出切割功能。我不知道如何做到这一点。

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

我想保留的表格（按顺序）是“Wells”和“Perforations”表

如果你想测试程序，这是一个井的序列号：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

FIN： Application.DisplayAlerts = True Application.ScreenUpdating = True 结束子

如果我能更好地解释一下，请告诉我。

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代码从互联网上检索2个表而不是1个表

1 个答案: