[英]Macro that follows a link and downloads the table into a new sheet
I am a geologist working for a small oil company in Louisiana.我是一名地质学家,在路易斯安那州的一家小型石油公司工作。 I constitute our tech department, and unfortunately my experience with coding is quite limited.
我组成了我们的技术部门,不幸的是,我在编码方面的经验非常有限。 I have used very basic vba coding in the past, but I dont code that much in my daily job, so I have forgotten most of it.
过去我使用过非常基本的 vba 编码,但我在日常工作中编码不多,所以我忘记了大部分。
The louisiana dnr keeps amazing records for every single oil well drilled in the state and all of these records are located at www.Sonris.com.路易斯安那州 dnr 为该州钻探的每一口油井都保存了惊人的记录,所有这些记录都位于 www.Sonris.com。 Part of these records are the production records for each well.
这些记录的一部分是每口井的生产记录。 I would like to create a macro that follows a given url and downloads the table found on the URL (aka the production records).
我想创建一个跟随给定 url 的宏并下载在 URL 上找到的表(又名生产记录)。 After it downloads the file, I would like it to put the table in a new sheet and then to name this sheet based on the well name.
下载文件后,我希望它将表格放在新工作表中,然后根据井名命名该工作表。
I have fooled around with the retrieve data from web function, however I cannot make the function dynamic enough.我已经在从 web 函数中检索数据上糊涂了,但是我不能使该函数足够动态。 I need the code to copy the hyperlink data found in a cell.
我需要代码来复制在单元格中找到的超链接数据。 Currently, the code just follows the hyperlink that I copy and paste while recording the macro.
目前,代码仅遵循我在录制宏时复制和粘贴的超链接。
Any help would be appreciated任何帮助,将不胜感激
Sincerely, Josiah真诚的,约西亚
Below is the code generated;下面是生成的代码;
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
With all of the methods available to scrub external data, many users forget that you can open a web page full of tables with nothing more than a valid URL and File ► Open.使用所有可用于清理外部数据的方法,许多用户忘记了您可以打开一个充满表格的网页,只需一个有效的 URL 和文件 ► 打开。 I'm posting the code here but I will also supply a link to a working sample workbook that took ~ 2 minutes to gather the full web page data from 14 sequentially numbered WSN ( web serial number ) pages.
我在这里发布代码,但我还将提供一个工作示例工作簿的链接,该工作簿花了大约 2 分钟从 14 个按顺序编号的 WSN(网络序列号)页面收集完整的网页数据。 Your own results may vary.
您自己的结果可能会有所不同。
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
The list of WSN identifiers are in the WSNs worksheet starting in column 2. Run the macro by tapping Alt + F8 to open the Macros dialog and Run the Gather_Well_Data macro.无线传感器网络标识符的列表是在传感器网络工作表中列2.运行开始通过敲击Alt + F8打开宏对话框,运行Gather_Well_Data宏宏。 When it is complete, you will have a workbook filled with worksheets identified by the WSNs similar to below.
完成后,您将拥有一个工作簿,其中包含由 WSN 标识的工作表,类似于以下内容。
The sample workbook is on my public DropBox at:示例工作簿位于我的公共 DropBox 上:
Just to piggy back on @Jeeped awesome solution, I added in the formating to delete and just have the LeaseUnit/Well/Production info left.只是为了支持@Jeeped 很棒的解决方案,我添加了要删除的格式,只留下 LeaseUnit/Well/Production 信息。 This assumes Casing table always follow the Production table
这假设套管表始终遵循生产表
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
Jeeped's method rocks.+1 Jeeped 的方法太棒了。+1
You can also issue POST
requests against the API and write all the tables out as follows.您还可以针对 API 发出
POST
请求并按如下方式写出所有表。
Note: I am writing each Well info one under the other but it is easy enough to put a Sheets.Add line in before the next API call and simply ensure each data write out uses the activesheet.注意:我将每个 Well 信息写在另一个下面,但在下一个 API 调用之前放入 Sheets.Add 行并简单地确保每个数据写出使用 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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.