This might fall under the dumb question from a newbie. But I honestly don't know where to start in VBA. I tried a few different approaches on the web trying to pull data from the site I'm trying to and all of them failed miserably. Can someone help me (more or less show me) how to pull the data from this website?
https://rotogrinders.com/projected-stats/nfl?site=fanduel
It wouldn't even let me do the data->import. here is what I have so far. I keep getting stuck on line For t = 0 To (Table.Length - 1).
Sub test1()
Dim appIE As Object
Set appIE = CreateObject("internetexplorer.application")
Dim Table As Object
Dim t As Integer
Dim r As Integer
Dim c As Integer
With appIE
.Navigate "https://rotogrinders.com/projected-stats/nfl?site=fanduel"
.Visible = True
End With
Do While appIE.Busy
DoEvents
Loop
Set Table = appIE.document.getElementById("proj-stats")
For t = 0 To (Table.Length - 1)
For r = 0 To (Table(t).Rows.Length - 1)
For c = 0 To (Table(t).Rows(r).Cells.Length - 1)
ThisWorkbook.Worksheets(1).Cells(r + 1, c + 1) = Table(t).Rows(r).Cells(c).innerText
Next c
Next r
Next t
appIE.Quit
Set appIE = Nothing
End Sub
You are close, and there are several ways to get the data. I chose to extract all row elements (HTML <TD>) and step through a simple loop. Since there are six columns I'm using two variables (r & c for row and column) to offset the data to format correctly.
Set Table = appIE.document.getElementsbytagname("td")
r = 0
c = 0
For Each itm In Table
Worksheets(1).Range("A1").Offset(r, c).Value = itm.innertext
c = c + 1
If c Mod 6 = 0 Then
r = r + 1
c = 0
End If
Next itm
Example Result:
One last note, sometimes the browser didn't finish loading before the script went on... I cheated by using a break point before the loop, waited until it loaded, then hit F5 to continue execution of code to ensure it would alway run.
Related
I have a problem on creating a macro for a certain situation.
I have a STAAD model which has 8 beams and 10 load cases.
I wanted to get the beam end forces for all the beams but only
load cases 1 and 2.
Here's the code
Sub ExtractLC_Click()
Sheets("COPING BEAM").Range("A:I").ClearContents
'Variable Declaration
Dim lMemberNo As Long
Dim lEnd As Long
Dim lLoadCase As Long
Dim dForceArray(6) As Double
Dim icount As Integer
Dim ret As Boolean
Dim path As String
path = Sheets("Main").Cells(185, 23).Value
Set staad = GetObject(, "StaadPro.OpenSTAAD")
staad.OpenSTAADFile path
'extract beam end forces
lMemberNo = Sheets("Main").Cells(184, 10).Value
For x = 2 To 6
lLoadCase = Sheets("SEISMIC").Range("B" & x).Value
ret = staad.Output.GetMemberEndForces(lMemberNo, lEnd, lLoadCase, dForceArray)
For icount = 0 To 5
Sheets("SEISMIC").Cells(x, 3 + icount).Value = dForceArray(icount)
Next icount
Next x
Set staad = Nothing
End Sub
However for the line:
Output.GetMemberEndForces(lMemberNo, lEnd, lLoadCase, dForceArray)
Only the START forces of the beam is extracted not the END.
Excel and STAAD comparison
I wanted both. Is there a certain code that involves opening STAAD,
copying ALL member end forces? Thanks for the help!
Good day!
You can add a loop statement for "lend".
Example:
For lend = 0 to 1
For x = 2 To 6
lLoadCase = Sheets("SEISMIC").Range("B" & x).Value
ret = staad.Output.GetMemberEndForces(lMemberNo, lEnd, lLoadCase, dForceArray)
For icount = 0 To 5
Sheets("SEISMIC").Cells(x, 3 + icount).Value = dForceArray(icount)
Next icount
Next x
next lend
Although you still have to edit the code a bit to paste the results in different cells.
so I thought this would be a simple logical problem, but for the life of me I cannot find the issue with this code block. I have checked around on Stack for a solution, but all other do/while loop problems appear to be primarily with other languages.
What I am trying to do is simply loop through an array & add a new worksheet for each element in the array that is not null. Pretty simple right? Yet for some reason it simply loops through once and thats it.
Here is the code block:
Dim repNames() As String
Dim x As Integer
x = 25
ReDim repNames(1 To x)
repNames(1) = "Ahern"
repNames(2) = "Castronovo"
repNames(3) = "Glick"
repNames(4) = "Fields"
repNames(5) = "Murphy"
repNames(6) = "Sleeter"
repNames(7) = "Vivian"
repNames(8) = "Walschot"
repNames(9) = "Wilson"
Dim i As Integer
i = 1
Do 'Loop keeps creating only 1 new sheet. Should create 9.
Worksheets.Add.Name = repNames(i)
i = i + 2
Loop While repNames(i) <> Null
I believe the problem is with this line: Loop While repNames(i) <> Null,
but obviously the logical test seems to hold up.
Any help would be hugely appreciated!
As others note, Null is not the comparison you want to make. Testing anything for equivalence with Null will return Null -- even ?Null = Null returns Null, which is why your loop is exiting early. (Note: To test for a Null, you need to use the IsNull function which returns a boolean, but that is NOT how you test for an empty string.)
In VBA, to test for a zero-length string or empty string, you can use either "" or vbNullString constant, or some people use the Len function to check for zero-length.
Rectifying that error, as originally written in your code, your logical test should abort the loop if any item is an empty string, but none of the items are empty strings (at least not in the example data you've provided) so you end up with an infinite loop which will error once i exceeds the number of items in the repNames array.
This would be probably better suited as a For Each loop.
Dim rep as Variant
For Each rep in repNames
Worksheets.Add.Name = rep
Next
If you need to skip empty values, or duplicate values, you can add that logic as needed within the loop:
For Each rep in repNames
If rep <> vbNullString 'only process non-zero-length strings
Worksheets.Add.name = rep
End If
Next
Etc.
Firstly, you should be comparing to vbNullString. This loops multiple times:
' Declare variables
Dim repNames() As String
Dim x As Integer
Dim i As Integer
' Set data
x = 25
ReDim repNames(1 To x)
repNames(1) = "Ahern"
repNames(2) = "Castronovo"
repNames(3) = "Glick"
repNames(4) = "Fields"
repNames(5) = "Murphy"
repNames(6) = "Sleeter"
repNames(7) = "Vivian"
repNames(8) = "Walschot"
repNames(9) = "Wilson"
' Loop through items
i = 1
Do
Worksheets.Add.Name = repNames(i)
i = i + 2
Loop While repNames(i) <> vbNullString
There is one more problem – why i = i + 2 ? In your question you say you wanted the loop to execute 9 times, but using i = i + 2 skips every other item. If you indeed want to loop through every item:
Do
Worksheets.Add.Name = repNames(i)
i = i + 1
Loop While repNames(i) <> vbNullString
Here you go, I have changed the loop conditional, and changed i=i+2 to i=i+1. A regular while loop would be better than a do while encase the first element is empty
Dim repNames()
Dim x As Integer
x = 25
ReDim repNames(1 To x)
repNames(1) = "Ahern"
repNames(2) = "Castronovo"
repNames(3) = "Glick"
repNames(4) = "Fields"
repNames(5) = "Murphy"
repNames(6) = "Sleeter"
repNames(7) = "Vivian"
repNames(8) = "Walschot"
repNames(9) = "Wilson"
Dim i As Integer
i = 1
Do While repNames(i) <> ""
Worksheets.Add.Name = repNames(i)
i = i + 1
Loop
Before I ask my question, I'm an amateur coder with basically no meaningful experience beyond VBA in ms office apps (I know - noob!)
I'm trying to create a web scraper using VBA to import data into excel and as per my comments in the below extract of code, the best I've been able to find on this is was in the winning answer to this question.
Below, I'm using investing.com as an example but in reality my project will be across multiple sites and will feed into a matrices which will be updating daily and self cannibalizing as events expire - For this reason I'd rather front-up the workload on the code side to make the inputs on an ongoing basis as minimal as possible (for me).
With that in mind, can I ask if there's a way to do any of the following (brace yourself, this will be cringe-worthy basic knowledge for some):
Is there a way in which I can and navigate to a url and run a for each loop on every table on that page (without have a known id for any)? this is to speed up my code as much as it's to minimise my inputs as there'll be quite a bit of data to be updated and I was planning on putting a 2 minute looping trigger on the refresh.
Instead of doing what I've been doing below, is it possible to reference a table, rather than a row, and do something along the lines of Cells(2,5).value to return the value within row 1, column 4? (assuming that both the array indexing starts at 0 in both dimensions?) Further to that, my first column (my primary key in some ways) may not be in the same order on all sources so is there a way in which I could do the equivalent to Columns("A:A").Find(What:=[Primary key], After:=Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=False).Row to find what row within the table relates to the even I'm looking for?
Code :
Sub Scraper()
Dim appIE, allRowOfData As Object
' As per https://stackoverflow.com/questions/27066963/scraping-data-from-website-using-vba
Set appIE = CreateObject("internetexplorer.application")
With appIE
.Navigate "http://uk.investing.com/rates-bonds/financial-futures" 'Sample page
.Visible = False
End With
Do While appIE.Busy
Application.Wait (Now + TimeValue("0:00:01")) 'If page not open, wait a second befor trying again
Loop
Set allRowOfData = appIE.document.getElementById("pair_8907")
'tr id="[ID of row within table]"
Dim myValue As String: myValue = allRowOfData.Cells(8).innerHTML
'The 8 is the column number of the table
'(note: column numbers start at 0 so the 9th column should have "8" entered here
Set appIE = Nothing
Range("A1").Value = myValue
End Sub
If you want to use Excel functions to navigate the tables why not dump the tables first onto a worksheet this code works for me
Option Explicit
Sub Scraper()
Dim appIE As Object
' As per http://stackoverflow.com/questions/27066963/scraping-data-from-website-using-vba
Set appIE = CreateObject("internetexplorer.application")
With appIE
.Navigate "http://uk.investing.com/rates-bonds/financial-futures" 'Sample page
.Visible = True
End With
Do While appIE.Busy
DoEvents
Application.Wait (Now + TimeValue("0:00:01")) 'If page not open, wait a second befor trying again
Loop
'Debug.Print TypeName(appIE.document)
Dim doc As Object 'MSHTML.HTMLDocument
Set doc = appIE.document
'* appIE busy is good but you need to wait for the whole document to completely load and initialise so use this
While doc.readyState <> "complete"
DoEvents
Wend
'* we can select all the tables because they share the same CSS class name
Dim tablesSelectedByClass As Object 'MSHTML.HTMLElementCollection
Set tablesSelectedByClass = doc.getElementsByClassName("genTbl")
'* you can change this, it was just convenient for me to add sheets to my workbook
Dim shNewResults As Excel.Worksheet
Set shNewResults = ThisWorkbook.Worksheets.Add
Dim lRowCursor As Long '* this controls pasting down the sheet
lRowCursor = 1
Dim lTableIndexLoop As Long
For lTableIndexLoop = 0 To tablesSelectedByClass.Length - 1
Dim tableLoop As Object 'MSHTML.HTMLTable
Set tableLoop = tablesSelectedByClass.Item(lTableIndexLoop)
If LenB(tableLoop.ID) > 0 Then '* there are some extra nonsense tables, this subselects
Dim sParentColumn As String, objParentColumn As Object ' MSHTML.HTMLSemanticElement
Set objParentColumn = FindMyColumn(tableLoop, sParentColumn) '* need to understand is table on left hand or right hand side
Dim vHeader As Variant: vHeader = Empty
If sParentColumn = "leftColumn" Then
'* tables on the left have a preceding H3 element with the table's description
Dim objH3Headers As Object
Set objH3Headers = objParentColumn.getElementsByTagName("H3")
vHeader = objH3Headers.Item(lTableIndexLoop).innerText
Else
'* tables on the right have a hidden attribute we can use
vHeader = tableLoop.Attributes.Item("data-gae").Value
If Len(vHeader) > 3 Then
vHeader = Mid$(vHeader, 4)
Mid$(vHeader, 1, 1) = Chr(Asc(Mid$(vHeader, 1, 1)) - 32)
End If
End If
'* tables on the right do not have column headers
Dim bHasColumnHeaders As Boolean
bHasColumnHeaders = (tableLoop.ChildNodes.Length = 2)
Dim vTableCells() As Variant '* this will be our table data container which we will paste in one go
Dim lRowCount As Long: lRowCount = 0
Dim lColumnCount As Long: lColumnCount = 0
Dim lDataHeadersSectionIdx As Long: lDataHeadersSectionIdx = 0
Dim objColumnHeaders As Object: Set objColumnHeaders = Nothing
If bHasColumnHeaders Then
Set objColumnHeaders = tableLoop.ChildNodes.Item(0).ChildNodes.Item(0)
lRowCount = lRowCount + 1
lDataHeadersSectionIdx = 1
Else
lDataHeadersSectionIdx = 0
End If
Dim objDataRows As Object 'MSHTML.HTMLElementCollection
Set objDataRows = tableLoop.ChildNodes.Item(lDataHeadersSectionIdx).ChildNodes
lColumnCount = objDataRows.Item(0).ChildNodes.Length
lRowCount = lRowCount + objDataRows.Length
ReDim vTableCells(1 To lRowCount, 1 To lColumnCount) As Variant
'* we have them get the column headers
Dim lColLoop As Long
If bHasColumnHeaders Then
For lColLoop = 1 To lColumnCount
vTableCells(1, lColLoop) = objColumnHeaders.ChildNodes.Item(lColLoop - 1).innerText
Next
End If
'* get the data cells
Dim lRowLoop As Long
For lRowLoop = 1 To lRowCount - VBA.IIf(bHasColumnHeaders, 1, 0)
For lColLoop = 1 To lColumnCount
vTableCells(lRowLoop + VBA.IIf(bHasColumnHeaders, 1, 0), lColLoop) = objDataRows.Item(lRowLoop - 1).ChildNodes.Item(lColLoop - 1).innerText
Next
Next
'* paste our table description
shNewResults.Cells(lRowCursor, 1).Value2 = vHeader
lRowCursor = lRowCursor + 1
'* paste our table data
shNewResults.Cells(lRowCursor, 1).Resize(lRowCount, lColumnCount).Value2 = vTableCells
lRowCursor = lRowCursor + lRowCount + 1
End If
Next
End Sub
Function FindMyColumn(ByVal node As Object, ByRef psColumn As String) As Object
'* this code ascends the DOM looking for "column" in the id of each node
While InStr(1, node.ID, "column", vbTextCompare) = 0 And Not node.ParentNode Is Nothing
DoEvents
Set node = node.ParentNode
Wend
If InStr(1, node.ID, "column", vbTextCompare) > 0 Then
Set FindMyColumn = node
psColumn = CStr(node.ID)
End If
End Function
By the way, if you trade a lot the brokers get rich and you get poor, brokerage charges really impact in long run.
I have been trying to get this VBA script to work to automate a task, but I cannot get it to work.
Basically, I have a big task list in excel with multiple columns and over 1000 Rows. It contains the task, who it is assigned to, and if it is open or closed.
In column H is who it assigned to and column N is whether the task is opened or closed.
I am trying to search by last name and if it is OPEN to add one to the counter. The end goal is to get a total count of how many open tasks a person has. Also, some of the cells in column N (task status) has extra text like comments, etc. I am sure that a InStr Function to search for the one word within the Cell would work better, but I cannot figure it out...
here is my code
Sub statuscount()
Dim tasksheet As Worksheet
Dim simons_count As Integer
Set tasksheet = ThisWorkbook.Sheets("tasks")
lr = tasksheet.Cells(Rows.Count, 1).End(xlUp).Row
For x = 5 to lr
If tasksheet.Cells(x, 8) = "Simons" And tasksheet.Cells(x, 14) = "OPEN" Then
simons_count = simons_count + 1
End If
Next x
tasksheet.Range("$O$5").Value = simons_count
End Sub
Thanks for the help!
Using If/And gets tricky in VBA, you're better off nesting two if statements:
For x = 5 to lr
If tasksheet.Cells(x, 8) = "Simons" Then
If InStr(tasksheet.Cells(x, 14).Value, "OPEN") > 0 Then
simons_count = simons_count + 1
End If
End If
Next x
This is a more general function. Insert a module and past the below code in it. Than you can use the function just like any other Excel built-in function
Function LastNamecounter(lastName As String, status As String) As Long
LastNamecounter = 0
Dim tasksheet As Worksheet
Set tasksheet = ThisWorkbook.Sheets("tasks")
lr = tasksheet.Cells(Rows.Count, 1).End(xlUp).Row
For i = 5 To lr
If InStr(tasksheet.Cells(i, 8).Value, lastName) <> 0 And InStr(tasksheet.Cells(i, 14).Value, status) <> 0 Then
LastNamecounter = LastNamecounter + 1
End If
Next i
End Function
I have a VBA macro that uses Microsoft MapPoint to calculate the distance between two locations for each record in my spreadsheet. I have about 120,000 records to process. The program runs smoothly for about 10,000 iterations then returns a Type Mismatch error where I define the MapPoint locations in my error handler. At which point, I select 'Debug' and then resume execution without editing any code, and it will run successfully for another 10,000 or so records before the same thing happens again.
I've checked my data, and I can't see why there would be a type mismatch, or for that matter why the code would choke on a record one time, and then, without resetting anything, handle the same record upon resuming. Any idea why this would happen?
For reference,
- column M contains locations of the form "X County, ST"
- column AN contains a separate location as ZIP
- column G contains the same location data as AN but in the form "X County, ST"
Sub distance_from_res()
Dim oApp As MapPoint.Application
Dim k As Long
Dim count As Long
Dim errors As Long
k = 0
count = Sheets("i1_20041").Range("A2", Sheets("i1_20041").Range("A2").End(xlDown)).count
errors = 0
Set oApp = CreateObject("MapPoint.Application.NA.11")
oApp.Visible = False
Set objMap = oApp.NewMap
Dim objRes As MapPoint.Location
Dim objFish As MapPoint.Location
'Error executes code at 'LocError' and then returns to point of error.
On Error GoTo LocError
Do While k < count
If Sheets("i1_20041").Range("M2").Offset(k, 0) <> "" Then
'Sets MapPoint locations as [County],[State] from Excel sheet columns "INT_CNTY_ST" and "ZIP".
Set objRes = objMap.FindResults(Sheets("i1_20041").Range("AN2").Offset(k, 0)).Item(1)
Set objFish = objMap.FindResults(Sheets("i1_20041").Range("M2").Offset(k, 0)).Item(1)
'Calculates distance between two locations and prints it in appropriate cell in Column AO.
Sheets("i1_20041").Range("AO2").Offset(k, 0) = objRes.DistanceTo(objFish)
Else
errors = errors + 1
End If
k = k + 1
Loop
'Displays appropriate message at termination of program.
If errors = 0 Then
MsgBox ("All distance calculations were successful!")
Else
MsgBox ("Complete! Distance could not be calculated for " & errors & " of " & count & " records.")
End If
Exit Sub
LocError:
If Sheets("i1_20041").Range("G2").Offset(k, 0) = "" Then
errors = errors + 1
Else
'THIS IS WHERE THE ERROR OCCURS!
Set objRes = objMap.FindResults(Sheets("i1_20041").Range("G2").Offset(k, 0)).Item(1)
Set objFish = objMap.FindResults(Sheets("i1_20041").Range("M2").Offset(k, 0)).Item(1)
'Calculates distance between two locations and prints it in appropriate cell in Column AO.
Sheets("i1_20041").Range("AO2").Offset(k, 0) = objRes.DistanceTo(objFish)
End If
k = k + 1
Resume
End Sub
UPDATE:
I incorporated most of the suggestions from #winwaed and #Mike D, and my code is now more accurate and doesn't choke on errors. However, the old problem reared its head in a new form. Now, after around 10,000 iterations, the code continues but prints the distance of the ~10,000th record for every record afterwards. I can restart the code at the trouble point, and it will find the distances normally for those records. Why would this happen? I've posted my updated code below.
Sub distance_from_res()
Dim oApp As MapPoint.Application
Dim k As Long
Dim rc As Long
Dim errors As Long
Dim dist As Double
Dim zipRes As Range
Dim coRes As Range
Dim coInt As Range
Dim distR As Range
Set zipRes = Sheets("Sheet1").Range("C2")
Set coRes = Sheets("Sheet1").Range("B2")
Set coInt = Sheets("Sheet1").Range("E2")
Set distR = Sheets("Sheet1").Range("G2")
k = 0
rc = Sheets("Sheet1").Range("F2", Sheets("Sheet1").Range("F2").End(xlDown)).Count
errors = 0
'Start MapPoint application.
Set oApp = CreateObject("MapPoint.Application.NA.11")
oApp.Visible = False
Set objMap = oApp.NewMap
Dim objResultsRes As MapPoint.FindResults
Dim objResultsInt As MapPoint.FindResults
Dim objRes As MapPoint.Location
Dim objInt As MapPoint.Location
Do While k < rc
'Check results for Res Zip Code. If good, set first result to objRes. If not, check results for Res County,ST. If good, set first result to objRes. Else, set objRes to Nothing.
Set objResultsRes = objMap.FindResults(zipRes.Offset(k, 0))
If objResultsRes.ResultsQuality = geoFirstResultGood Then
Set objRes = objResultsRes.Item(1)
Else
Set objResultsRes = Nothing
Set objResultsRes = objMap.FindResults(coRes.Offset(k, 0))
If objResultsRes.ResultsQuality = geoFirstResultGood Then
Set objRes = objResultsRes.Item(1)
Else
If objResultsRes.ResultsQuality = geoAmbiguousResults Then
Set objRes = objResultsRes.Item(1)
Else
Set objRes = Nothing
End If
End If
End If
Set objResultsInt = objMap.FindResults(coInt.Offset(k, 0))
If objResultsInt.ResultsQuality = geoFirstResultGood Then
Set objInt = objResultsInt.Item(1)
Else
If objResultsInt.ResultsQuality = geoAmbiguousResults Then
Set objInt = objResultsInt.Item(1)
Else
Set objInt = Nothing
End If
End If
On Error GoTo ErrDist
distR.Offset(k, 0) = objRes.DistanceTo(objInt)
k = k + 1
Loop
Exit Sub
ErrDist:
errors = errors + 1
Resume Next
End Sub
You are constructing a somewhat complex range object (Range -> Offset -> Item). DIM temporary range objects and do it in steps so you can see where exactly the problem occurs
tmpR1 = Sheets("i1_20041").Range("G2")
tmpR2 = tmpR1.Offset(k,0)
then examine the .Count property of the .FindResult before you try accessing Item(1) .... maybe this item doesn't exist ?!?
Debug.Print objMap.FindResult(tmpR2).Count
Hint:
looking at your code, I observe that you use a variable "count". This variable name overlaps with the "Count" property in your second line of code - that's why the "Count" keyword at the end of the statement is printed all lowercase. It's not got anything to do with the errors (we pretend ;-) ), but bad style anyway.
MikeD is right with your dangerous FindResults() calls. However, there is a better way to check the results. The "FindResults collection" isn't a pure collection but includes an extra properties called "ResultsQuality". Docs are here:
http://msdn.microsoft.com/en-us/library/aa493061.aspx
Resultsquality returns a GeoFindResultsQuality enumeration. You want to check for the values geoAllResultsGood and geFirstResultGood. All other results should give an error of some result. Note that your existing code would work find with (for example) Ambiguous Results, even though it is unlikely the first result is the correct one. Also it might match on State or Zipcode (because that is the best it can find) whcih give you an erroneous result. Using ResultsQuality, you can detect this.
I would still check the value of Count as an additional check.
Note that your code is calculating straight line (Great Circle) distances. As such the bottleneck will be the geocoding (FindResults). If you are using the same locations a lot, then a caching mechanism could greatly speed things up.
If you want to calculate driving distances, then there are a number of products on the market for this (yes I wrote two of them!).