VBA in Excel web data fetching loop - vba

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


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

Related

VBA: printing on the last row of excel

I am planning to extract data from a table on the web. The code below was mostly from built-in web scraping function in Excel.
What I want is to find the last row with data and print on the first blank row.
Sub Sub1()
ActiveSheet.Cells.Clear
Dim lastRow As Long
Dim i As Integer
For i = 1 To 2
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://www.aastocks.com/tc/stocks/quote/symbolsearch.aspx?page=" & i & " &order=symbol&seq=asc", Destination _
:=Range("A,lastRow")) '???? I got an error here, what I want is to detect the last row and print on the first blank row.???
'.CommandType = 0
.Name = "symbolsearch_1"
.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 = "10"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
Debug.Print lastRow
Next i
End Sub

This seems to work ok now. You were close, you should be able to edit as required.
Sub Sub1()
ActiveSheet.Cells.Clear
Dim lastRow As Long
Dim i As Integer
Dim sTicker As String
'set the first row to write to
lastRow = 2
For i = 1 To 2
sTicker = InputBox("Enter the code to search for")
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://www.aastocks.com/tc/stocks/quote/symbolsearch.aspx?page=" & sTicker & " &order=symbol&seq=asc", Destination _
:=Range("A" & lastRow)) 'uses the ticker value entered and fixed the destination part
'.CommandType = 0
.Name = "symbolsearch_1"
.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 = "10"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
Next i
End Sub

How to loop my Current VBA Code

I need to modify with loop my existing VBA. I have a part of website link in Column A. I want to dynamic below this line.
ticjername = Sheet1.Range("A1").Value
I need to loop it, because I want to continue this code until data found in Column A.
My Code:
Sub Macro1()
'
' Macro1 Macro
'
' Keyboard Shortcut: Ctrl+q
'
Dim ticjername As String
ticjername = Sheet1.Range("A1").Value
mURL$ = "http://www.example.com=" & ticjername
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;" & mURL, Destination:=Range("B1"))
.Name = " "
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = False
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "1"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Columns("B:C").Select
Selection.Delete Shift:=xlToLeft
Columns("B:B").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.Delete Shift:=xlUp
Range("B1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Cut
Sheets("Sheet2").Select
ActiveCell.Select
ActiveSheet.Paste
Range("A" & Rows.Count).End(xlUp).Offset(1).Select
End Sub

Try below code
Dim rowID As Integer
rowID = 1
Do
'<Your code>
rowID = rowID + 1
Loop Until Sheet1.Cells(rowID, 1).Value = ""
Credit goes to www.stackoverflow.com

Looped macro to create a new sheet, rename it, add data from the web, then loop back through until complete

Trying to create a macro to take a spreadsheet with two columns (one with names, the other with a URL to a sheet I need data from), create a new sheet for each row, rename that sheet according to the name in column A, then create a web query in the new sheet according to the URL in column B.
Here's the macro I tried compiling, but it's not working.
Sub CreateSheetsFromAList()
Dim wb As Workbook
Dim src As Worksheet
Dim tgt As Worksheet
Dim MyCell As Range, MyRange As Range, URLCell As Range
Set wb = ThisWorkbook
Set src = wb.Sheets("AllPlayers")
Set MyRange = Sheets("AllPlayers").Range("A1")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
Set URLCell = Sheets("AllPlayers").Range("B1")
Set URLCell = Range(URLCell, URLCell.End(xlDown))
For Each MyCell In MyRange
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = MyCell.Value
With ActiveSheet.QueryTables.Add(Connection:=URLCell, Destination:=Range("$A$2"))
.Name = "2015"
.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 = """pgl_basic"""
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
Next MyCell
End Sub

Made some syntax tweaks that should help as well as error handling if the sheet name already exists. Didn't make any changes to the QueryTable.Add method though.
Sub CreateSheetsFromAList()
Dim wb As Workbook
Dim src As Worksheet
Dim tgt As Worksheet
Dim ActSht As Worksheet
Dim MyCell As Range, MyRange As Range, URLValue As Variant
Set wb = ThisWorkbook
Set src = wb.Sheets("AllPlayers")
Set MyRange = src.Range("A1:A" & src.Range("A" & src.Rows.Count).End(xlUp).Row)
For Each MyCell In MyRange
On Error Resume Next
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = MyCell.Value
If Err.Number > 0 Then
Err.Clear
MsgBox MyCell.Value & " sheet name already exists"
Exit Sub
End If
On Error Goto 0
URLValue = MyCell.Offset(0, 1).Value
Set ActSht = Sheets(Chr(34) & MyCell.Value & Chr(34))
With ActSht.QueryTables.Add(Connection:= "URL;" & URLValue, Destination:=ActSht.Range("A2"))
.Name = "2015"
.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 = """pgl_basic"""
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Next MyCell
End Sub

Import data from web: repeat loop

I have this VBA script that works:
Sub Basic_Web_Query()
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;" & ActiveSheet.Range("A2").Value, Destination:=Range("E2"))
.Name = "q?s=goog_2"
.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 = "2"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
End Sub
I want the macro to do this in a loop, i.e. go to A3 with destination E3, A4 with destination A4... etc.
any help will be appreciated
thansk!

I like to use 'offset' for these loops: OFFSET(rows down, columns right).
Negative values move up and left.
for example:
for p= 1 to 5
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;" & ActiveSheet.Range("A2").offset(p-1,0).Value, Destination:=Range("E2").offset(p-1,0))
'other code
End With
next p

google 'loop vba' and you will hit plenty of examples. Here's one:
Dim rw As Long
For rw = 1 To 5
Range("E" & rw).Value = Range("A" & rw).Value
'other stuff
Next rw

File loop not pulling the referenced worksheet range in normal code

I have written a code in my personalxlsb file that automatically pulls in reports from a website using a webquery. The code (listed directly below) works great when I open each excel workbook individually and run the code. z,x, and y refernce a value on Sheet1 for each workbook (they are vlookups to other data). I have looked and looked and cant find a solution. thanks for any help in advance!
Dim ws As Worksheet
z = Worksheets("Sheet1").Range("$A$1").Value
y = Worksheets("Sheet1").Range("$A$2").Value
x = Worksheets("Sheet1").Range("$A$3").Value
For Each ws In Worksheets
If ws.Name = "ATB by Branch" Then
With Worksheets("ATB by Branch").QueryTables.Add(Connection:= _
"URL;https://pe.---.com/---/clients/---" & y & "/amr/amr" & z & "/tb01" & x _
, Destination:=Worksheets("ATB by Branch").Range("$A$1"))
.Name = "tb0120130903110631ash"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlOverwrtiteCells
.SavePassword = True
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=True
End With
ElseIf ws.Name = "ATB by Ins by Sum" Then
The problem is when i attempt to run this code for each file (listed below) in a folder the code ceases to pull in the data and I suspect the issue is that the z,y, and x variables are no longer pulling the correct values.
Dim wkbOpen As Workbook
Dim sht As Worksheet
Dim MyPath As String
Dim MyFile As String
MyPath = "C:\Documents and Settings\tlear\Desktop\Copy of VBA Physician Files\"
MyFile = Dir(MyPath & "*.xls")
Do While Len(MyFile) > 0
Set wkbOpen = Workbooks.Open(Filename:=MyPath & MyFile)
With wkbOpen
Dim ws As Worksheet
z = Worksheets("Sheet1").Range("$A$1").Value
y = Worksheets("Sheet1").Range("$A$2").Value
x = Worksheets("Sheet1").Range("$A$3").Value
For Each ws In Worksheets
If ws.Name = "ATB by Branch" Then
With Worksheets("ATB by Branch").QueryTables.Add(Connection:= _
"URL;https://pe.----.com/---/clients/----" & y & "/amr/amr" & z & "/tb01" & x _
, Destination:=Worksheets("ATB by Branch").Range("$A$1"))
.Name = "tb0120130903110631ash"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlOverwrtiteCells
.SavePassword = True
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=True
End With
Any help would be greatly appreciated

Try this proper formatted, you missed some . within the With blocks. This compiles fine but i cannot test. Just curious do you need to close them at the end?
Sub SO_18897512()
Dim MyPath As String
Dim MyFile As String
Dim ws As Worksheet
MyPath = "C:\Documents and Settings\tlear\Desktop\Copy of VBA Physician Files\"
MyFile = Dir(MyPath & "*.xls")
Do While Len(MyFile) > 0
With Workbooks.Open(Filename:=MyPath & MyFile)
Z = .Worksheets("Sheet1").Range("$A$1").Value
y = .Worksheets("Sheet1").Range("$A$2").Value
x = .Worksheets("Sheet1").Range("$A$3").Value
For Each ws In .Worksheets
If ws.Name = "ATB by Branch" Then
With ws.QueryTables.Add( _
Connection:= "URL;https://pe.----.com/---/clients/----" & y & "/amr/amr" & Z & "/tb01" & x , _
Destination:=ws.Range("$A$1"))
.Name = "tb0120130903110631ash"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlOverwrtiteCells
.SavePassword = True
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=True
End With
End If
Next
End With
Loop
End Sub