跟随链接并将表格下载到新表格中的macros

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

路易斯安那州自然科学研究院保留了在该州钻探的每一口油井的惊人logging，所有这些logging均位于www.Sonris.com。 这些logging的一部分是每口井的生产logging。 我想创build一个跟随给定URL的macros，并下载在URL上find的表（也就是生产logging）。 在下载文件之后，我希望将表格放在新的表格中，然后根据井名命名该表格。

我曾经从webfunction中检索数据，但是我不能使这个function足够dynamic。 我需要代码来复制在单元格中find的超链接数据。 目前，代码只是在录制macros时复制和粘贴的超链接。

任何帮助，将不胜感激

真诚的，约西亚

以下是生成的代码;

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

只是为了捎带@Jeeped真棒解决scheme，我添加在格式化删除，只剩下LeaseUnit /井/生产信息。 这假设shell表总是遵循生产表

 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 

Answer 2

利用所有可用于清理外部数据的方法，许多用户会忘记您只能打开一个充满表格的网页，而无需使用有效的URL和文件►打开。 我在这里发布代码，但我也会提供一个工作示例工作簿的链接，花费大约2分钟的时间从14个顺序编号的WSN（ Web序列号 ）页面收集完整的网页数据。 你自己的结果可能有所不同

 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列开始的WSNs工作表中。通过点击Alt + F8打开macros对话框并运行 Gather_Well_Datamacros来运行macros。 完成后，您将会在工作簿中填入WSN标识的工作表，如下所示。

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

LA_WSN_Data.xlsb