VBA in Excel web data fetching loop

Question

 Sub Button1_Click()

 Set ws = ActiveWorkbook.Sheets("Sheet1")
 Set ws2 = Worksheets("Sheet2")

Range("A2:P100").ClearContents

With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://www6.landings.com/cgi-bin/nph-search_nnr?  pass=193800885&&nnumber=" & ws2.Range("E2").Value _
, Destination:=Range("$G$4"))
.Name = "nph-search_nnr?pass=193800885&&nnumber=22A"
.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 = "18"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False

 'Copy to Another sheet

     ws.Range("I7").Copy
     ws2.Range("A20000").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

     ws.Range("I8").Copy
     ws2.Range("B20000").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

     ws.Range("I6").Copy
     ws2.Range("C20000").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

     ws.Range("I5").Copy
     ws2.Range("D20000").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues



   Worksheets("Sheet2").Columns("A:P").AutoFit



 End With

 End Sub

I wrote that code with help of recorded macro, it gets certain info from the website, I need to automate that process and after clicking Button_1 it should loop through all existing cell values of column E in Worksheets("Sheet2")(except the header).I am guessing between each loop it should wait until data are fully retrieved and loaded, that coding is too much for me to handle yet...

Simply in each looped run part of web address ( ws2.Range("E2").Value ) has to be replaced with next row in column in Sheet2 column E

I wasn't able to test my solution but it should work. Let me know how it goes and if we need to tweak it. — user6432984
– user6432984, Commented Jul 10, 2016 at 1:46
Sorry, I should have caught that. I add Option Explicit to the top of the code modules. This forces variable declaration and makes it easier to debug the macros. It's fixed now. — user6432984
– user6432984, Commented Jul 10, 2016 at 2:24

score 1 · Accepted Answer · 2016-07-10 02:22:22Z

This should do it.

Update: I added Application.ScreenUpdating = False to speed up the macro.

Option Explicit

Sub Button1_Click()
    Dim lastRow As Long, x As Long

    Application.ScreenUpdating = False

    With Worksheets("Sheet2")

        lastRow = .Range("D" & Rows.Count).End(xlUp).Row

        For x = 2 To lastRow

            RequeryLandings .Cells(x, "E")

        Next

        .Columns("A:P").AutoFit

    End With

    Application.ScreenUpdating = True

End Sub


Sub RequeryLandings(address As String)

    Dim ws As Worksheet

    Set ws = ActiveWorkbook.Sheets("Sheet1")

    Range("A2:P100").ClearContents

    With ActiveSheet.QueryTables.Add(Connection:= _
                                     "URL;http://www6.landings.com/cgi-bin/nph-search_nnr?  pass=193800885&&nnumber=" & address _
                                     , Destination:=Range("$G$4"))
        .Name = "nph-search_nnr?pass=193800885&&nnumber=22A"
        .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 = "18"
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False

        DoEvents

        'Copy to Another sheet

        With Worksheets("Sheet2")
            .Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = ws.Range("I7")
            .Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = ws.Range("I8")
            .Range("C" & Rows.Count).End(xlUp).Offset(1, 0) = ws.Range("I6")
            .Range("D" & Rows.Count).End(xlUp).Offset(1, 0) = ws.Range("I5")
        End With
    End With

End Sub

Collectives™ on Stack Overflow

VBA in Excel web data fetching loop

1 Answer 1

2 Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

1 Answer 1

2 Comments

Your Answer

Sign up or log in

Post as a guest

Related