Selenium Webdriver VBA - New Loop for Error - excel

Goodnight
I would like some help if possible. I'm putting this code together, but I'm not able to create an output if it doesn't find the page item. I would like if he doesn't find the intem he would go to the next line, not displaying an error message as I have a lot of data to capture.
Dim drive As New Selenium.ChromeDriver
Dim ks As Selenium.Keys
Dim tempo As Integer
Set ks = New Selenium.Keys
site = "http://www.google.com"
Plan1.Select
tell = Range("A" & Rows.Count).End(xlUp).Row
Line = 4
drive.Start
drive.Get site
Do Until Cells(Linha, 1) = ""
For Line = 4 To tell
Number = Range("A" & Linha).Value
drive.SwitchToFrame drive.FindElementById("WIDGET_ID_4")
Set telephone = drive.FindElementByXPath("/html/body/.........")
Range("B" & Line).Value = telephone.Attribute("outerText")
drive.SwitchToDefaultContent
Next Linha
Loop
drive.Quit
MsgBox "Process Ok"
End Sub```

Within the loop, test if the tab is found i.e. if not tab is nothing then do stuff.....else move to next id. Wrap the SET line in an On Error Resume Next On Error GoTo 0 pair to suppress potential element not found exception.
I think linha should be line and Number be used to set the next id.
Please do note that using unqualified ranges e.g. Range without specifying the worksheet, you are implicitly referencing the current ActiveSheet and this is bug-prone.
Do Until Cells(Line, 1) = vbNullString
For Line = 4 To tell
Number = Range("A" & Line).Value
Dim targetTab As webElement
On Error Resume Next 'suppress potential exception
Set targetTab = drive.FindElementById("WIDGET_ID_4")
On Error GoTo 0 'switch exception raising back on
If Not targetTab Is Nothing Then 'test if reference obtained for target element
drive.SwitchToFrame targetTab
Set telephone = drive.FindElementByXPath("/html/body/.........")
Range("B" & Line).Value = telephone.Attribute("outerText")
drive.SwitchToDefaultContent
Set targetTab = Nothing
End If
Next Line
Loop

Related

Application crashes when ComboBox1 of 2 changes value - ComboBox1 change event

I'm a VBA NewBe (this is my first post asking a question on any VBA help site) working on a Property/Expense Management application in excel. the ComboBoxes in question are used to select worksheets based on a Property ID, propID, in cmbPropID based on a range in a "Control" worksheet and the worksheet year, wsYr, in cmbYear determined by the individual propID's beginning year, wsStartYr, and the current calendar year, wdCurYear. I am able to select/activate and view all worksheets of the first property I select. However, when I select another property to work on the application crashes with Debug error: 9 - Script out of range! I have been going blind for over a week searching for a solution without success.
This issue is important in the overall functionality of the application. I hope someone is able to help me with this. Thanks in advance.
Below are the code sections for the ComboBoxes
The first configures cmbPropID
'this is an excert form MultiPage1
Case 2
'configure cmbPropID DDL
wkstControl.Activate
selectedRow = cmbPropID.ListIndex + 3 'I presume this is 3 instead of 2 because when using 2
'this throws an error - not sure why
For Each cPart In wsCntrl.Range(Range("propIDs"), Range("A" & Rows.Count).End(xlUp))
pAct = wsCntrl.Cells(selectedRow, 11).Value 'Value used to test the "isActive" status of a RealEstate property location
With Me.cmbPropID
If pAct = True And cPart.Value <> "" Then cmbPropID.AddItem cPart.Value 'Never Shows pAct as False ???
'this presents an issue that if is inActive of does'nt have worksheets it causes
' Debug error "Error: 13, Type Mismatch"
End With
Next cPart
This sub configures the contents of the cmbYears DDL and should reset the DDL's contents when selection a different propID ... see notes in next sub-routine
Private Sub cmbPropID_Change()
Dim i
Dim strValue As String
wsCntrl.Activate
pID = ""
wsA = ""
wsYr = ""
selectedRow = cmbPropID.ListIndex + 2
wsStartYr = wsCntrl.Cells(selectedRow, 13).Text
With cmbYears
.Clear
For i = wsStartYr To wbCurYear
pAct = wsCntrl.Cells(selectedRow, 11).Value
If wbCurYear <> wsStartYr And pAct = True Then
.AddItem i
ElseIf wbCurYear = wsStartYr Then
.AddItem wbCurYear
End If
Next i
End With
lstDsplyUtil1.RowSource = ""
pID = cmbPropID.Text
End Sub
and finally, cmbYears. The code crashes at Set wsUtil = Worksheets(wsA) when a when cmbPropID changes.
Private Sub cmbYears_Change()
wsYr = cmbYears.Text
wsA = pID & "_" & wsYr
Debug.Print pID, wsYr, wsA
Set wsUtil = Worksheets(wsA)
lstDsplyUtil1.RowSource = wsA & "!$A$5:$Y$16"
Debug.Print pID, wsYr, wsA
'Remove after testing
Label120.Caption = wsA
Label136.Caption = pID
Label138.Caption = wsYr
Label134.Caption = lstDsplyUtil1.RowSource
wsUtil.Activate
End Sub
I went back to troubleshooting the Crash Issue after posting my Question. I developed the habit of creating Labels on the various UserForms, assigned their .Caption value equal to the the various Variable values, and used Debug.Print to track those Values in the Immediate Window.
What I noticed was that when Debug threw its Error the Immediate Window showed the new pID Value after the cmbPropID_Change() Event to be the same as BEFORE the cmbPropID_Change Event and the cmbPropID.ListIndex = -1 when it should have been >=0 depending on the selection in cmbPropID. This lead me think that the problem was with the cmbPropID_Change() Event configuration. However, no matter what changes I made to the cmbPropID_Change() Event configuration the issue remained.
I began looking at the cmbYears_Change() Event configuration where the Error happens and it occurred to me that I could pre-Trap and thereby avoid the Error by encapsulating cmbYears_Change() code in a set of If Then ElseIf statements like this:
If cmbYears.ListIndex <> -1 Then
'cmbYears' original code
ElseIf cmbYears.ListIndex >= 0 Then
'cmbYears' original code
End If
This worked perfectly and this is the final code!
Private Sub cmbYears_Change()
If cmbYears.ListIndex <> -1 Then
pID = cmbPropID.Text
wsYr = cmbYears.Text
wsA = pID & "_" & wsYr
lstDsplyUtil1.RowSource = wsA & "!$A$5:$Y$16"
Debug.Print pID, wsYr, wsA
Set wsUtil = Worksheets(wsA)
wsUtil.Select
ElseIf cmbYears.ListIndex >= 0 Then
pID = cmbPropID.Text
wsYr = cmbYears.Text
wsA = pID & "_" & wsYr
lstDsplyUtil1.RowSource = wsA & "!$A$5:$Y$16"
Debug.Print pID, wsYr, wsA
Set wsUtil = Worksheets(wsA)
wsUtil.Select
End If
End Sub
Issue Resolved!

Is there a way to incorporate a timer within a for loop to loop incase code is taking too long to execute?

I have a VBA macro that cycles through a list of 1500 PDF Files Ranging from 60 to 500 pages. The code checks each file from the list to see if it contains a certain keyword obtained from a user. The code seems to bug out sometimes if the file is too big, so I limited each pdf that will be searched to 12 MB.
Now The problem I am having is that randomly the macro will just stall on a random file and not do anything regardless of file size. It will just stay on that file unless I go and move the mouse.
So I was wondering what the best way to tackle this would be? I was thinking of adding an event of moving the mouse before and after the .FindText method, but I think the best way would be to limit the time each file is open to 30 seconds. I am not sure how to incorporate it within the loop though, Thanks.
Also if you have any suggestions on other improvements I would aprreciate it thank you.
Sub PDFSearch()
Dim FileList As Worksheet, Results As Worksheet
Dim LastRow As Long, FileSize As Long
Dim KeyWord As String
Dim TooLarge As Boolean
Dim PDFApp As Object, PDFDoc As Object
Application.DisplayAlerts = False
Set FileList = ThisWorkbook.Worksheets("Files")
Set Results = ThisWorkbook.Worksheets("Results")
LastRow = FileList.Cells(Rows.Count, 1).End(xlUp).Row
KeyWord = InputBox("What Term Would You Like To Search For?")
Results.Rows(3 & ":" & .Rows.Count).ClearContents
For x = 3 To LastRow
TooLarge = False
FileSize = FileLen(FileList.Cells(x, 1).Value) / 1000
If FileSize > 12000 Then TooLarge = True
If TooLarge = False Then
Set PDFApp = CreateObject("AcroExch.App")
If Err.Number <> 0 Then
MsgBox "Could not create the Adobe Application object!", vbCritical, "Object Error"
Set PDFApp = Nothing
Exit Sub
End If
On Error Resume Next
App.CloseAllDocs 'Precautionary - Sometimes It Doesn't Close The File
On Error GoTo 0
Set PDFDoc = CreateObject("AcroExch.AVDoc")
If Err.Number <> 0 Then
MsgBox "Could not create the AVDoc object!", vbCritical, "Object Error"
Set PDFDoc = Nothing
Set PDFApp = Nothing
Exit Sub
End If
If PDFDoc.Open(FileList.Cells(x, 1).Value, "") = True Then
PDFDoc.BringToFront
If PDFDoc.FindText(KeyWord, False, False, True) = True Then
Results.Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = FileList.Cells(x, 1).Value
End If
End If
PDFApp.Exit
End If
On Error Resume Next
PDFDoc.BringToFront 'Precautionary - Sometimes Command Doesn't Close The File
PDFApp.Exit
On Error GoTo 0
Set PDFDoc = Nothing
Set PDFApp = Nothing
FileSize = 0
Next x
Application.DisplayAlerts = True
End Sub

Method 'Color' of object 'Font' failed

I'm getting the title error message in my Excel 2010 VBA code. I've looked at this question and this question which both look similar, but nether seems to address the issue.
My code parses through all the conditional formatting on the current worksheet and dumps it as text to another (newly created) worksheet - the ultimate goal is to load those same conditions to a nearly identical worksheet (thus I can't just copy the base worksheet).
The code is:
Public Sub DumpExistingRules()
'portions of the code from here: http://dailydoseofexcel.com/archives/2010/04/16/listing-format-conditions/
Const RuleSheetNameSuffix As String = "-Rules"
Dim TheWB As Workbook
Set TheWB = ActiveWorkbook
Dim SourceSheet As Worksheet
Set SourceSheet = TheWB.ActiveSheet
Dim RuleSheetName As String
RuleSheetName = SourceSheet.Name & RuleSheetNameSuffix
On Error Resume Next 'if the rule sheet doesn't exist it will error, we don't care, just move on
Application.DisplayAlerts = False
TheWB.Worksheets(RuleSheetName).Delete
Application.DisplayAlerts = True
On Error GoTo EH
Dim RuleSheet As Worksheet
Set RuleSheet = TheWB.Worksheets.Add
SourceSheet.Activate
RuleSheet.Name = RuleSheetName
RuleSheet.Range(RuleSheet.Cells(1, CellAddrCol), RuleSheet.Cells(1, OperatorCodeCol)).Value = Array("Cell Address", "Rule Type", "Type Code", "Applies To", "Stop", "Font.ColorRGB", "Formula1", "Formula2", _
"Interior.ColorIndexRGB", "Operator Type", "Operator Code")
Dim RuleRow As Long
RuleRow = 2
Dim RuleCount As Long
Dim RptCol As Long
Dim SrcCol As Long
Dim RetryCount As Long
Dim FCCell As Range
For SrcCol = 1 To 30
Set FCCell = SourceSheet.Cells(4, SrcCol)
For RuleCount = 1 To FCCell.FormatConditions.Count
RptCol = 1
Application.StatusBar = "Cell: " & FCCell.Address
PrintValue RuleSheet, RuleRow, CellAddrCol, FCCell.Address
PrintValue RuleSheet, RuleRow, RuleTypeCol, FCTypeFromIndex(FCCell.FormatConditions.Item(RuleCount).Type)
PrintValue RuleSheet, RuleRow, RuleCodeCol, FCCell.FormatConditions.Item(RuleCount).Type
PrintValue RuleSheet, RuleRow, AppliesToCol, FCCell.FormatConditions.Item(RuleCount).AppliesTo.Address
PrintValue RuleSheet, RuleRow, StopCol, FCCell.FormatConditions.Item(RuleCount).StopIfTrue
If FCCell.FormatConditions.Item(RuleCount).Type <> 8 Then
PrintValue RuleSheet, RuleRow, Formula1Col, "'" & Right(FCCell.FormatConditions.Item(RuleCount).Formula1, Len(FCCell.FormatConditions.Item(RuleCount).Formula1) - 1) 'remove the leading "=" sign
If FCCell.FormatConditions.Item(RuleCount).Type <> 2 And _
FCCell.FormatConditions.Item(RuleCount).Type <> 1 Then
PrintValue RuleSheet, RuleRow, Formula2Col, "'" & Right(FCCell.FormatConditions.Item(RuleCount).Formula2, Len(FCCell.FormatConditions.Item(RuleCount).Formula2) - 1) 'remove the leading "=" sign
End If
End If
RetryCount = 0
RetryColor:
PrintValue RuleSheet, RuleRow, FontColorCol, "'" & GetRGB(FCCell.FormatConditions(RuleCount).Font.Color)
PrintValue RuleSheet, RuleRow, IntColorIdxCol, "'" & GetRGB(FCCell.FormatConditions.Item(RuleCount).Interior.Color)
If FCCell.FormatConditions.Item(RuleCount).Type = 1 Then
PrintValue RuleSheet, RuleRow, OperatorTypeCol, OperatorType(FCCell.FormatConditions.Item(RuleCount).Operator)
PrintValue RuleSheet, RuleRow, OperatorCodeCol, FCCell.FormatConditions.Item(RuleCount).Operator
End If
RuleRow = RuleRow + 1
Next
Next
RuleSheet.Rows(1).AutoFilter = True
CleanExit:
If RuleRow = 2 Then
PrintValue RuleSheet, RuleRow, RptCol, "No Conditional Formatted cells were found on " & SourceSheet.Name
End If
On Error Resume Next
Set SourceSheet = Nothing
Set TheWB = Nothing
Application.StatusBar = ""
On Error GoTo 0
MsgBox "Done"
Exit Sub
EH:
If Err.Number = -2147417848 Then
MsgBox "Font.Color = " & FCCell.FormatConditions(RuleCount).Font.Color
If RetryCount < 5 Then
RetryCount = RetryCount + 1
Resume RetryColor
Else
MsgBox "RetryCount = " & RetryCount
Resume Next
End If
Else
MsgBox "Error Number: " & Err.Number & vbCrLf & _
" Description: " & Err.Description & vbCrLf & _
"Cell Address: " & FCCell.Address & vbCrLf
Resume Next
End If
End Sub
The line in question is the one immediately following the RetryColor: label. When that line of code is executed for a Unique Values conditional formatting rule (i.e. highlight duplicates), I get err.number = -2147417848' and err.description = "Method 'Color' of object 'Font' failed". The code drops to EH:, falls into the first IF statement, and displays the MsgBox without any problem.
Why is it that the statement FCCell.FormatConditions(RuleCount).Font.Color fails the first time, but executes perfectly the second time in the error handler? Once I've clicked the OK button on the MsgBox, execution resumes at the RetryColor: label, the statement executes correctly, and all is good.
To make sure this is clear, if I comment out the
MsgBox "Font.Color = " & FCCell.FormatConditions(RuleCount).Font.Color
line in EH:, the code will error 5 times without ever outputting the RGB code to my output worksheet, then continue on its way. If that line is in EH: (as shown above), I get the MsgBox and the .Font.Color will now be read in the main code and execution will continue as expected without error.
UPDATE: It seems that after letting this code sit for a week while I worked on something else, that it's now slightly more broken. In the error handler, I now get the titular error message popping, up. If I hit F5, it will execute and display the MsgBox with the color code.
So now, it will fail twice, then execute properly the 3rd time.
For completeness, here's the code for GetRGB:
Private Function GetRGB(ByVal ColorCode As Variant) As String
Dim R As Long
Dim G As Long
Dim B As Long
If IsNull(ColorCode) Then
GetRGB = "0,0,0"
Else
R = ColorCode Mod 256
G = ColorCode \ 256 Mod 256
B = ColorCode \ 65536 Mod 256
GetRGB = R & "," & G & "," & B
End If
End Function
I have to pass the parameter as a Variant because when the .Font.Color is set to Automatic in the color chooser, I get a NULL returned, thus the If statement in GetRGB.
Another Update: After letting this code sit for a few more weeks (it's to make my life easier, not an official project, therefore it's at the bottom of the priority list), it seems that it will generate the error on every call now, instead of just sometimes. However, the code will execute properly in the immediate window!
The yellow highlighted line is the one that generated the error, yet you can see the results in the immediate window.
Also (I realize this should really be another question), if anybody happens to quickly see any reason for the SourceSheet.Activate line, please let me know - I was getting random errors without it, so I put that in. Usually these errors are because of unqualified references working on the currently active sheet (which would be RuleSheet as soon as it's created), but I thought I had all my references qualified. If you see something I missed, please pipe up! Otherwise, I'll probably head over to CodeReview to have them take a look at what I missed once I get this working properly.
I think I've reduced this to a root cause.
I manually added 2 different types of FormatConditions in cell Sheet1.A1:
And here's my code, in the same workbook.
Sub foo()
Dim rng As Range
Set rng = Sheet1.Range("A1")
Dim fc As Object
On Error Resume Next
Sheet2.Activate
Set fc = rng.FormatConditions(1)
Debug.Print ActiveSheet.Name, TypeName(fc), fc.Type
Debug.Print , fc.Font.Color
Set fc = rng.FormatConditions(2)
Dim fnt As Font2
Debug.Print ActiveSheet.Name, TypeName(fc), fc.Type
Debug.Print , fc.Font.Color
Sheet1.Activate
Set fc = rng.FormatConditions(1)
Debug.Print ActiveSheet.Name, TypeName(fc), fc.Type
Debug.Print , fc.Font.Color
Set fc = rng.FormatConditions(2)
Debug.Print ActiveSheet.Name, TypeName(fc), fc.Type
Debug.Print , fc.Font.Color
End Sub
And here's the output:
Sheet2 FormatCondition 1
3243501
Sheet2 Top10 5
Sheet1 FormatCondition 1
3243501
Sheet1 Top10 5
13998939
So the FormatConditions.Item method will not always return a FormatCondition
I can't reproduce your Immediate Window behavior, so maybe you inadvertently activated the sheet?
If I remove the On Error Resume, and break at the error for the Top10.Font.Color call, and then query in the debug window, I get:
Run-time error '-2147417848 (80010108)':
Automation error
The object invoked has disconnected from its clients.
For which Google takes me to Error or Unexpected Behavior with Office Automation When You Use Early Binding in Visual Basic
Based on my results, when the FormatConditions.Item returns a Top10 (and maybe other types, including your UniqueValues type), it isn't possible to access the Font.Color property unless the range's sheet is active.
But it looks like you have it active? I wonder if you're changing the active sheet in PrintValue?
Regarding your second question:
I have always have had problems with setting cells that are not in an active sheet, the most probable cause for the problem in doing SourceSheet.Activate relies on the fact of the Set range later:
Set FCCell = SourceSheet.Cells(4, SrcCol)
I've found that, if the sheet is not active, it would fail within the cells() argument, I think the best approach for this is using Range before Cells.
This may be the case.
So for this example I would do something like:
With SourceSheet:Set FCCell = .Range(.Cells(4,SrcCol):End With

Excel VB Scripting Error Handling - "object variable or with block not set" Error

I'm having some trouble with a macro for Excel. The snippet that's giving me trouble is responsible for:
1) allowing the user to select multiple column headers, one by one
2) taking the contents of each columns, in the order of header selection, and concatenating
Here's the code:
Dim concat1() As Range
Dim rng As Variant
Dim i As Variant
Dim g As Integer
Dim metalabels() As String
Dim concated As String
Dim s As Variant
lastrow = Cells(rows.Count, "A").End(xlUp).Row
i = 0
msgselect = MsgBox("Would you like to concatonate?", vbOKCancel)
On Error GoTo Errhandler
If msgselect = vbOK Then
Do
ReDim Preserve concat1(i)
Set concat1(i) = Application.InputBox("Select the headers you would like to concatonate", Default:=ActiveCell.Address, Type:=8)
msgselect = MsgBox("Another cell?", vbOKCancel)
i = i + 1
Loop While msgselect = vbOK
i = i - 1
Errhandler:
End If
ReDim metalabels(i)
For g = 0 To i
metalabels(g) = concat1(g).Text
Next
ActiveSheet.Range("a1").End(xlToRight).Offset(0, 1).Select
ActiveCell = "Situation"
For h = 1 To lastrow - 1
For g = 0 To UBound(metalabels)
concated = concated + metalabels(g) + ": " + concat1(g).Offset(h, 0).Text + " / "
Next
ActiveCell.Offset(h, 0).Value = concated
concated = ""
Next
End Sub
The problem is here:
Set concat1(i) = Application.InputBox("Select the headers you would like to concatonate", Default:=ActiveCell.Address, Type:=8)
If the user selects "Cancel," the code crashes since the loop depends on vbOK. So, I thought I'd put in an error handler, but, as it is, I get the "object variable or with block not set" error.
As you might sense, I'm still a nube with VB. Any help is greatly appreciated.
Thanks!
Place this after your End IF
If concat1(i) Is Nothing Then Exit Sub
Did you try adding if concat1(i) = false then exit sub before incrementing i?

Morningstar expected return

I have this code that I have tweaked below. I use it to scrape other morningstar data, but I can't seem to make it work now for "expected return" for ETFs(Exchange Traded Funds). Everything on the code right now is set up to get the data that I need but I am having a problem getting it on the excel spreadsheet. When I do a msgBox tblTR under the code:
Set tblTR = Doc.getElementsByClassName("pr_text3")(4).innerText
I get the expected value on the message box.
However, when I take the msgbox code out, the value doesn't appear in the excel spreadsheet. I have been trying to work it out for hours now and need HELP!
Below is the entire code. under tab "Tickers2" is where I have all the tickers I would like to pull data. Examples JKE, JKF, JKD...which I have about 1000. under tab "ExpectedReturn" is where I want the data to be displayed. I think it has to do with me pulling elementsbyclassname versus when I used to pull the elementsbytagname. There wasn't in tagnames in the information i needed so I switched it to class name. Below is the entire code.
I will also mention that you have to be signed in to morningstar.com in order to get the actual data, but I am assuming that the forum can point me in the right direction without needing to be signed in.
The website is www.morningstar.com
Sub ExpectedReturn()
Dim IE As Object, Doc As Object, lastRow As Long, tblTR As Object, tblTD As Object, strCode As String
lastRow = Range("A65000").End(xlUp).Row
Set IE = CreateObject("internetexplorer.application")
IE.Visible = True
last_row = Sheets("Tickers2").Range("A1").End(xlDown).Row
ini_row_dest = 1
Sheets("ExpectedReturn").Select
Sheets("ExpectedReturn").Range("A1:H10000").ClearContents
Application.ScreenUpdating = True
For i = 1 To lastRow
Application.StatusBar = "Updating upDown" & i & "/" & last_row
row_dest = ini_row_dest + (i - 1)
strCode = "Tickers2" ' Range("A" & i).value
list_symbol = Sheets("Tickers2").Range("A" & i)
IE.navigate "http://etfs.morningstar.com/quote?t=" & list_symbol
Do While IE.readyState <> 4: DoEvents: Loop
Set Doc = CreateObject("htmlfile")
Set Doc = IE.document
tryAgain:
Set tblTR = Doc.getElementsByClassName("pr_text3")(4).innerText
MsgBox tblTR
If tblTR Is Nothing Then GoTo tryAgain
On Error Resume Next
j = 2
For Each tblTD In tblTR.getElementsByTagName("td")
tdVal = Split(tblTD.innerText, vbCrLf)
Cells(i, j) = tdVal(0)
Cells(i, j + 1) = tdVal(1)
j = j + 2
Next
Sheets("ExpectedReturn").Range("A" & row_dest).Value = list_symbol
Next i
Range("A3").Select
Application.StatusBar = False
Application.Calculation = xlAutomatic
End Sub
Thank you in advance.
-Eddie
By setting
Set tblTR = Doc.getElementsByClassName("pr_text3")(4).innerText
the variable tblTR is a string. You want a dom element, so remove the .innerText
Only then you can loop over its TD-children further down.
This was my fix
tblTR=Doc.ElementsByClassName("pr_text3)(4).innerText
Sheets("ExpectedReturn").Range("B"& row_dest).Value=tblTR

Resources