I am fetching currency rate through a web query. The issue i am facing is that if i want to run the loop more then 20 time then it gets hanged as i am new to VBA so i required some assistance how to improve the execution speed.
Below is my code.
Sub CurrencyConvert()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Fcurrency As String, Scurrency As String
Dim i As Integer
Static k As Integer
Worksheets.Add.Name = "Temp"
k = First.Cells(Rows.Count, 3).End(xlUp).Row
For i = k + 1 To k + 16
Fcurrency = First.Cells(i, 1)
Scurrency = First.Cells(i, 2)
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://www.xe.com/currencyconverter/convert/?Amount=1&From=" & Fcurrency & "&To=" & Scurrency, _
Destination:=Worksheets("Temp").Range("$A$1"))
.Name = "?Amount=1&From=" & Fcurrency & "&To=" & Scurrency
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlAllTables
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
ActiveSheet.Cells(1, 4) = VBA.Left(ActiveSheet.Cells(1, 3), VBA.InStr(1, ActiveSheet.Cells(1, 3), " "))
ActiveSheet.Cells(1, 4).Copy First.Cells(i, 3)
Worksheets("Temp").UsedRange.Clear
First.Cells(1, 5) = "Total Converted:-" & k
Next i
Worksheets("Temp").Delete
Application.ScreenUpdating = True
MsgBox "Done"
End Sub
This is the format of my sheet.
CUR1 CUR2 Current Rates
USD USD 1
USD INR 61.9169
USD GBP 0.604447
USD EUR 0.721379
USD AED 3.6728
USD JOD 0.7079
USD MXN 13.1101
USD ARS 6.473
It looks like you are running a query to the server for every single row.
There is a lot of overhead in a new query, and for a relatively small amount of information (20 rows or so) you should probably run a query that includes ALL the exchange rates, and use a recordset object to iterate through each rate, THEN output to excel after.
Related
I have a function i mostly found on web, to get a table from Google Sheets.
Sub GetDataFromGoogle(wsn As String, address As String)
Dim i As Integer
With Worksheets(wsn)
With .QueryTables.Add(Connection:="URL;" & address, Destination:=.Range("$A$1"))
.PreserveFormatting = False
.BackgroundQuery = True
.WebFormatting = xlWebFormattingNone
.Refresh BackgroundQuery:=False
End With
DoEvents
End With
For i = 1 To ThisWorkbook.Connections.Count
If ThisWorkbook.Connections.Count = 0 Then Exit Sub
ThisWorkbook.Connections.item(i).Delete
i = i - 1
Next i
End Sub
It seems to work well, but as i develloped my data base, a problem happened.
I only get the first 100 entries of my google sheet, then i got a empty line, a strange text on the first next range, and then the line under in position 3 the word List
I have no idea of what it is.
Sub Uygula()
Sheets("Veri").Range("A1:D600").ClearContents
Call GetDataFromGoogle("Veri", "18I8Vddjir3lFvtUorMln4mXlYNsY0KZtBGywVreped4")
End Sub
Sub GetDataFromGoogle(wsn As String, adres As String)
Dim i As Integer
Dim qry As String
Dim myURL As String
qry = Application.EncodeURL("SELECT A, C, G, B")
myURL = "https://docs.google.com/spreadsheets/d/" & adres & "/gviz/tq?tqx=out:csv&sheet=1&tq=" & qry
With Worksheets(wsn)
With .QueryTables.Add(Connection:="TEXT;" & myURL, Destination:=.Range("$A$1"))
.Name = "myTable"
.TextFilePlatform = 65001
.SaveData = False
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.Refresh BackgroundQuery:=False
End With
'DoEvents
End With
'For i = 1 To ThisWorkbook.Connections.Count
'If ThisWorkbook.Connections.Count = 0 Then Exit Sub
'ThisWorkbook.Connections.Item(i).Delete
'i = i - 1
'Next i
End Sub
I am trying to write a loop macro to Excel VBA that takes a flight path from a cell in Sheet 1 (starting at row 1993), inserts the path into a website that calculates the flight data (Great Circle Mapper, shown here: http://www.gcmap.com/), pulls the data from a table on the website into Sheet 2 (starting at row 1996), deletes excess data, and removes "mi" from the miles flown (to leave a numerical value).
My first problem seems to begin with the start of the macro.
While I have defined the counter variable, the cell value variable, and the URL string variable (to concatenate with the cell value variable), debugging shows that only the counter variable gets properly initialized. The cell value variable ("Flight" which is supposed to start at row 1993, column O) does not get initialized, which then causes the URL and name variables not to run properly. Shown here:
ToInfinity = 1993
Flight = Cells(ToInfinity, 15).Value
url = "URL;http://www.gcmap.com/dist?P=" & Flight
name = "dist?P=" & Flight
As for my second problem, on the few times the macro has initialized each variable, the connection argument shown here:
("With ActiveSheet.QueryTables.Add(Connection:= _
url, Flight:=Range("$A$1996:$G$1996"))
Gives me a runtime error, and this block of code is highlighted by the debugger.
The entirety of my code is shown below:
Sub PULLFROMGCM()
'
' PULLFROMGCM Macro
' Pulls data from great circle mapper
'
' Keyboard Shortcut: Ctrl+Shift+T
'
Dim Flight As String
'String variable for each flight path to be analyzed by the website, "Great Circle Mapper"
'
Dim url As String
Dim ToInfinity As Long
' Counter variable for loop, beginning at row 1993 on sheet 1'
Dim name As String
Dim Milesflown As String
ToInfinity = 1993
Flight = Cells(ToInfinity, 15).Value
url = "URL;http://www.gcmap.com/dist?P=" & Flight
name = "dist?P=" & Flight
Do While Not IsEmpty(Cells(ToInfinity, 15))
Sheets("Sheet2").Select
With ActiveSheet.QueryTables.Add(Connection:= _
url, Flight:=Range("$A$1996:$G$1996"))
.CommandType = 0
.name = name
.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 = """mdist"""
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Milesflown = "G:2001"
ActiveCell.Range("A1996:G2000").Select
Selection.QueryTable.Delete
Selection.ClearContents
Sheets("Sheet1").Select
If InStr(Milesflown, "mi") <> 0 Then
Cells(ToInfinity, 11).Value = Left(Milesflown, " ")
End If
ToInfinity = ToInfinity + 1
Loop
End Sub
Link to Excel file from Google Drive
The obvious mistake in your code is that you are not updating the Flight, url and name variables inside your loop.
Correcting the above mistakes, and a few syntax errors (like using ActiveCell instead of ActiveSheet), the following code does what you want.
Sub PULLFROMGCM()
'
' PULLFROMGCM Macro
' Pulls data from great circle mapper
'
' Keyboard Shortcut: Ctrl+Shift+T
'
Dim Flight As String
Dim url As String
Dim ToInfinity As Long
Dim name As String
Dim Milesflown As String
ToInfinity = 1993
Do While Not IsEmpty(Cells(ToInfinity, 15))
' Update the variables in your loop as well
Flight = Cells(ToInfinity, 15).Value
url = "URL;http://www.gcmap.com/dist?P=" & Flight
name = "dist?P=" & Flight
' Calculate how far sheet 2 has rows
Sheets("Sheet2").Select
HowFar = Application.WorksheetFunction.CountA(Range("A:A")) + 3
With ActiveSheet.QueryTables.Add(Connection:= _
url, Destination:=Range("A" & (HowFar + 1) & ":G" & (HowFar + 1)))
.name = name
.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 = """mdist"""
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Milesflown = Range("G" & (HowFar + 6)).Value
ActiveSheet.Range("A" & (HowFar + 1) & ":G" & (HowFar + 5)).Select
Selection.QueryTable.Delete
Selection.ClearContents
Sheets("Sheet1").Select
If InStr(Milesflown, "mi") <> 0 Then
Milesflown = Replace(Milesflown, "mi", "")
Cells(ToInfinity, 12).Value = Milesflown
End If
MsgBox (Milesflown)
ToInfinity = ToInfinity + 1
Loop
End Sub
Good Day everyone. I'm new to VBA and was working with the following code to figure out how to query multiple tables. I would like the code to go to 100000 rows but I wanted to see how far it could actually run. Sadly, after the 29714th row, it gave me : Run-Time error 1004 'Application-defined or object-defined error'. I don't have a clue as to what is wrong other than the loop parameters might be too big. Any ideas?
Sub Data()
Dim qtb As New QueryTable
Dim url1 As String
Dim i As Long
For i = 2 To 540602 Step 24
url1 = Sheet2.Range("A" & i)
Set qtb = Sheet2.QueryTables.Add(Connection:="URL;" & url1, Destination:=Range("B" & i))
qtb.WebTables = "5"
qtb.FieldNames = True
qtb.RowNumbers = False
qtb.FillAdjacentFormulas = False
qtb.PreserveFormatting = True
qtb.RefreshOnFileOpen = False
qtb.BackgroundQuery = False
qtb.RefreshStyle = xlInsertDeleteCells
qtb.SavePassword = False
qtb.SaveData = False
qtb.AdjustColumnWidth = False
qtb.RefreshPeriod = 0
qtb.WebSelectionType = xlSpecifiedTables
qtb.WebFormatting = xlWebFormattingNone
qtb.WebPreFormattedTextToColumns = True
qtb.WebConsecutiveDelimitersAsOne = True
qtb.WebSingleBlockTextImport = False
qtb.WebDisableDateRecognition = False
qtb.WebDisableRedirections = False
qtb.Refresh BackgroundQuery:=False
Next i
MsgBox ("X")
End Sub
Here's what I came up with. As suggested in the comments, I create the full QueryTable the first time around. After that, I just change the connection to the next cell. The web addresses are now in each row, not every 24. The code steps through them and copies the output to a new sheet for each one. My testing involved only two sites. I don't know how many it will let you create before failing:
Sub Data()
Dim ws As Excel.Worksheet
Dim qtb As QueryTable
Dim url1 As String
Dim i As Long
Set ws = ActiveSheet 'or ws if you prefer
For i = 2 To 3 'links are in each row
url1 = ws.Range("A" & i)
If i = 2 Then
Set qtb = ws.QueryTables.Add(Connection:="URL;" & url1, Destination:=ws.Range("B1"))
With qtb
.WebTables = "5"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Else
qtb.Connection = "URL;" & url1
qtb.Refresh BackgroundQuery:=False
End If
ws.Copy after:=ws.Parent.Worksheets(ws.Parent.Worksheets.Count)
ActiveSheet.Columns(1).EntireColumn.Delete
Next i
End Sub
I am using Excel 2011 to execute the following query:
WEB
1
http://careers.accel.com/careers_home.php?p=1
Selection=EntirePage
Formatting=All
PreFormattedTextToColumns=True
ConsecutiveDelimitersAsOne=True
SingleBlockTextImport=False
I was wondering if there is a way to loop through the values of pages, i.e. "p=1" in the URL auto increments to "p=2". Additionally this query returns the pages numbers on top of the table, I was wondering if there is a way to modify my selection so only the main table appears.
Solved using visual basic. Couldn't figure out removing the page numbers though:
' Macro2 Macro
'
For x = 1 To 5
Worksheets("names").Select
Worksheets("names").Activate
mystr = "URL;http://careers.accel.com/careers_home.php?p=1"
mystr = Cells(x, 1)
Worksheets("pages").Activate
'Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = x
'
With ActiveSheet.QueryTables.Add(Connection:=mystr, Destination:=Range("$A" & Cells.SpecialCells(xlCellTypeLastCell).Row + 1))
.PostText = "accel"
.Name = False
.FieldNames = False
.RefreshStyle = xlInsertDeleteCells
.RowNumbers = False
.FillAdjacentFormulas = False
.HasAutoFormat = True
.RefreshOnFileOpen = 1
.BackgroundQuery = False
.TablesOnlyFromHTML = True
.SaveData = True
.Refresh BackgroundQuery:=False
.UseListObject = False
End With
Next x
End Sub
I am working on a small excel project where I have a user form. The user form has a combo box that has a list of company names retrieved from column (A) in an excel worksheet (This works as expected).
The form has a text box, that depending on the selection from the drop down box returns the stock ticker from column B (Works as expected).
The next step is where it breaks down. The stock ticker value is then passed to a web query that connects to yahoo finance, and retrieves data from the site.
Problem 1:
The web query does not return data until the form is closed. I want it to return the values "instantly."
Problem 2:
Each time I run the query, a new query table is built, even though I have coded my script to delete query tables.
Private Sub cb_Stock_Name_Change()
Set ws = Worksheets("Stock_Info")
With Me
.tb_ticker.Value = ws.cells(.cb_stock_name.ListIndex + 2, 2)
'.TextBox3.Value = Format(Sheet1.cells(.ComboBox1.ListIndex + 7, 9), "0%")
'.TextBox2.Value = Format(Sheet1.cells(.ComboBox1.ListIndex + 7, 10), "0%")
End With
Dim ticker As String
Dim conn As String
Set ws_query = Worksheets("Stock_Query")
ticker = tb_ticker.Value
conn = "URL;http://finance.yahoo.com/q?s=" & ticker
Dim qt As QueryTable
For Each qt In ws_query.QueryTables
qt.Delete
Next qt
Set qt = ws_query.QueryTables.Add _
(Connection:=conn, Destination:=Range("A1"))
With qt
'.Connection = conn
'.Destination = Range("A1")
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebSelectionType = xlSpecifiedTables
.WebTables = "2"
.Refresh
End With
With Me
.tb_previous_close.Value = ws_query.cells(1, 2)
End With
End Sub
Questions:
What is wrong with my code that is a) doesn't return until my form is closed b) doesn't delete the previous querytable?
Problem 1 - resolved as per the comments (need to put form property as Modeless). You can check MSDN for details on form's mode properties. FYI, by default the forms are modal.
Problem 2 - You need to specify qt's .Name property. Sample this
With qt
.Name = "StockWatch"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingAll
.WebTables = "2"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = False
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Let me know if this works for you