I'm making a program in Microsoft Excel using a bunch of VB script macros.
One of my macros gets data "From Web" and retrieves the table to a sheet in excel. When I say "From Web", I just copied and pasted the URL from an html file I have on my desktop. The location of my program is going to change frequently, so I need to be able to have a cell in excel where I can specify this URL, which my macro will reference.
Here is my code below:
Sub ImportSwipeDataWithTitlesBeta()
'
' ImportSwipeDataWithTitlesBeta Macro
'
' Keyboard Shortcut: Ctrl+Shift+K
'
Sheets("Import Swipe Data").Select
Cells.Select
Selection.Delete Shift:=xlUp
Range("A3").Select
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;file:///C:/Users/Sean/Desktop/Attendance Program ADC/ACS%20OnSite%20SE%20Complete.htm", _
Destination:=Range("$A$3:$C$3"))
.Name = "ACS%20OnSite%20SE%20Complete_8"
.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
Sheets("Resource Sheet").Select
Range("B2:C2").Select
Selection.Copy
Sheets("Import Swipe Data").Select
Range("A1:B1").Select
ActiveSheet.Paste
Range("A2").Select
End Sub
Thanks for the Help!
You don't need to .Select every range you use. These statements are generated by recording a macro but you can clean your code afterwards as described here.
Yet, to answer your question, you can store your URL in a var:
Dim myURL As String
myURL = "URL;" & Sheets("Import Swipe Data").Range("A1").Value
With ActiveSheet.QueryTables.Add(Connection:= myURL, Destination:=Range("$A$3:$C$3"))
(...)
End With
Regards,
Related
How should I scrape this webpage https://www.bseindia.com/stock-share-price/asian-paints-ltd/asianpaint/500820/ and specifically need the ROE figure which is mentioned in the table?
I used the following code in Excel. I don't know much about Google Sheets Scraping
Sub FetchData()
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;https://www.bseindia.com/stock-share-price/asian-paints-ltd/asianpaint/500820/", Destination:=Range( _
"$A$1"))
.Name = "www"
.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
End Sub
I was not able to fetch the data properly.
Any suggestions/help on this? Need the ROE figure rest of it is not required.
Use the API that the page uses it much faster. You can use powerquery to handle json response, a json parser or just use split. Put code in a standard module and link to a button if you want to refresh at a button press.
Option Explicit
Public Sub GetInfo()
Dim s As String, ids(), i As Long
ids = Array(500820, 500312, 500325, 532540)
With CreateObject("MSXML2.XMLHTTP")
For i = LBound(ids) To UBound(ids)
.Open "GET", "https://api.bseindia.com/BseIndiaAPI/api/ComHeader/w?quotetype=EQ&scripcode=" & ids(i) & "&seriesid=", False
.send
s = .responseText
ActiveSheet.Cells(i + 1, 1) = Split(Split(s, """ROE"":""")(1), Chr$(34))(0)
Next
End With
End Sub
Following is the way I find easier to get that particular value. Once the for loop detects ROE, it will go after the required value and exit the loop as they both are within the same parent node.
Sub FetchData()
Dim IE As New InternetExplorer, post As Object
Dim Html As HTMLDocument, elem As Object
With IE
.Visible = False
.navigate "https://www.bseindia.com/stock-share-price/asian-paints-ltd/asianpaint/500820/"
While .Busy Or .readyState < 4: DoEvents: Wend
Set Html = .document
End With
For Each post In Html.getElementsByTagName("td")
If post.innerText = "ROE" Then
Set elem = post.ParentNode.querySelector(".textvalue")
Exit For
End If
Next post
[A1] = elem.innerText
End Sub
References to add:
Microsoft Html Object Library
Microsoft Internet Controls
unfortunately, that won't be possible because the site is controlled by JavaScript and Google Sheets can't understand/import JS. you can test this simply by disabling JS for a given link and you will see a blank page:
all you can get is what you see:
=ARRAY_CONSTRAIN(IMPORTDATA("https://www.bseindia.com/stock-share-price/asian-paints-ltd/asianpaint/500820/"), 5000, 15)
I've run into a bit of a problem with making my macros compatible with OSX where it works on windows.
I have the following issue:
Compile error: Can't find project or library error when running the macro on Office 2016 on a MAC
The code/ function is used to change specific ranges to Upper Case / Proper case. The debugger highlights "UCase(Cell)" and "Cell"
Sub ChkSheet()
'=========================================================================
' Format the cell boarders when the info needs to be corrected or updated
'=========================================================================
Dim historyWks As Worksheet
Set historyWks = Worksheets("Namelist")
Dim lRow As Long
Dim emailRng As Range
Dim Cell As Range
With historyWks
' Flags cells where the Email fieldcontains invalid characters
lRow = Range("G" & Rows.Count).End(xlUp).Row
Set emailRng = Range("Q2:Q" & lRow)
For Each Cell In emailRng
If Cell.Value = "," _
Or Cell.Value = " " _
Or Cell.Value = "wd" _
Or Cell.Value = "" _
Or Cell.Find("#") Is Nothing Then
Cell.Interior.Color = vbRed
Else:
Cell.Interior.ColorIndex = 0
End If
Next
'Change the text case
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
For Each Cell In Range("NListUpper")
Select Case True
Case Application.IsText(Cell) = True
Cell = UCase(Cell)
End Select
Next Cell
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
'Change the case to proper
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
For Each Cell In Range("NListProp")
Select Case True
Case Application.IsText(Cell) = True
Cell = StrConv(Cell, vbProperCase)
End Select
Next Cell
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End With
End Sub
I've noticed that some libraries are missing on Excel 2016 on OSX and i'm aware that MS has dropped many libraries out of Excel for OSX.
Any advice on this would be just great.
Can you try avoiding using default properties of the Range object - they might differ between Windows and OSX:
So, instead of:
Select Case True
Case Application.IsText(Cell) = True
Cell = UCase(Cell)
End Select
Can you just try:
If Application.IsText(Cell.Value) Then
Cell.Value = UCase(Cell.Value)
End If
I am trying to rewrite my windows VBA code so i can use it on a Mac computer.
But somehow it is not possible to load the information into an active worksheet on mac.
Where MyFiles is the csv file opened by the code of http://www.rondebruin.nl/mac/mac015.html
.
I broke down the code a bit because i thought it didn't recognize the workbook. But i think the problem lies in the work book.
Set ws = ActiveWorkbook.Sheets("1. Pledges (ruw)")
MyFiles = MacScript(MyScript)
On Error GoTo 0
If MyFiles <> "" Then
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
With ws.QueryTables.Add(Connection:="TEXT;" & MyScript, Destination:=ws.Range("A1"))
.TextFileParseType = xlDelimited
.TextFileCommaDelimiter = True
.Refresh
End With
If ws.Range("A2").Value = vbNullString Then
ws.rows("2").EntireRow.Delete
End If
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
End Sub
Some how it always crashes on the .refresh even if i use the code of robin the bruijn i can't use the querytables which work perfectly on windows.
Original windows code:
Dim ws As Worksheet, strFile As String
Set ws = ActiveWorkbook.Sheets("1. Pledges (ruw)") 'set to current worksheet name
strFile = Application.GetOpenFilename("Text Files (*.csv),*.csv", , "Please selec text file...")
With ws.QueryTables.Add(Connection:="TEXT;" & strFile, Destination:=ws.Range("A1"))
.TextFileParseType = xlDelimited
.TextFileCommaDelimiter = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.SaveData = True
End With
If ws.Range("A2").Value = vbNullString Then
ws.rows("2").EntireRow.Delete
End If
I am trying to read multiple CSVs into single spreadsheet. I got below code from google.
There are 10 CSVs present in "C:\Users\achayapa\Desktop\test". I need to have each of these CSVs in a single excel. could someone please help?
I am new to vb script.
Sub MacroLoop()
Dim strFile As String
Dim ws As Worksheet
strFile = Dir("C:\Users\achayapa\Desktop\test\*.csv")
Do While strFile <> vbNullString
ws = Sheets.Add
With ws.QueryTables.Add(Connection:= _
"TEXT;" & "C:\Users\achayapa\Desktop\test\" & strFile, Destination:=Range("$A$1"))
.Name = strFile
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh(BackgroundQuery:=False)
End With
strFile = Dir
Loop
End Sub
I just thought of sharing the answer to above question.
Create a VBA script as below:
Sub Macro1()
Dim strPath As String
Dim strFile As String
strPath = "C:\test\"
strFile = Dir(strPath & "*.csv")
Do While strFile <> ""
With ActiveWorkbook.Worksheets.Add
With .QueryTables.Add(Connection:="TEXT;" & strPath & strFile, _
Destination:=.Range("A1"))
.Parent.Name = Replace(strFile, ".csv", "")
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End With
strFile = Dir
Loop
End Sub
In above code include for path - '\' For example - C:\test\
After this follow include above VBA in Excel, follow steps as in below link:
http://www.ablebits.com/office-addins-blog/2013/12/06/add-run-vba-macro-excel/
Short answer: Yes it is possible.
Step 0 of long answer:
There are 2 syntactical errors in you SWub MacroLoop():
ws = Sheets.Add must be Set ws = Sheets.Add because you want to assign an object to ws.
.Refresh(BackgroundQuery:=False) must be .Refresh BackgroundQuery:=False because you must not use param list () when calling (a function/method as) a Sub (see here).
You may get problems with .TextFilePlatform and .TextFileTrailingMinusNumbers - at least I did when testing on my rather dated Excel. If so, disable those lines (' comment) and try again.
For the next step I would need a detailed account of your testing experience. What result do you expect and how did the actual outcome differ from that?
I am trying to import data from web to Excel worksheet on win 7.
But, I do not know how to finish the left one where is marked .
Sub Ex2Macro()
Ex2 from Macro1 Macro
' Macro changed 17/07/2007 by Dr. B. I. Czaczkes
Dim qt As QueryTable
Dim temp As Variant ' Double
Set qt = ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://finance.yahoo.com/q?s=GBPUSD=X", Destination:=ActiveCell.Range("A1"))
With qt
.Name = "query1"
.BackgroundQuery = False
.SaveData = True
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "14"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.Refresh BackgroundQuery:=False
End With
With qt.ResultRange
.ClearContents
.Range("a1").Value = "USD/GBP"
.Range("b1").Value = ? ' here, what I should put so that the queried result
' is printed ?
End With
End Sub
Another piece of code that provide the exchange result.
Sub Ex3Macro()
Dim qt As QueryTable
' Dim temp As Double
Dim temp As Variant
temp = ActiveCell.Value
Set qt = Worksheets("temp").QueryTables.Add(Connection:= _
"URL;http://finance.yahoo.com/currency/convert?amt=" & _
temp & _
"&from=USD&to=GBP&submit=Convert" _
, Destination:=Worksheets("Temp").Range("a1"))
With qt
.Name = "query2"
.BackgroundQuery = False
.SaveData = True
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "13"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.Refresh BackgroundQuery:=False
End With
ActiveCell.Range("b1").Value = qt.ResultRange.Range("e3").Value
End Sub
But, no result is printed.
Any help will be appreciated.
Try selecting the Microsoft WinHTTP Services, version 5.1 reference then using this:
Sub HTTPTest()
Dim httpRequest As WinHttpRequest
Dim URL As String, strHTML As String
If httpRequest Is Nothing Then
Set httpRequest = New WinHttp.WinHttpRequest
End If
URL = "http://finance.yahoo.com/q?s=GBPUSD=X"
httpRequest.Open "GET", URL, True
httpRequest.Send
httpRequest.WaitForResponse
strHTML = httpRequest.ResponseText
Set httpRequest = Nothing
'Parse strHTML now to get your value
End Sub