I'm writing a Windows Form App on VS2019 that will open an excel file and perform nested loop.
Basically, there are two lists of integer. The code is going to loop through every row to check if the value of cell A exist in any of the lists, then assign a string to cell B.
The list in the original code has around 400 elements, but I cut it down to post here. Then something interesting happens. When I run the original code with 400+ elements, it loops the row and stopped halfway, then it gives me the "Exception from HRESULT: 0x800AC472". However, when I run the codes below it has no error.
So I thought if the huge list is the problem. I wonder if any of you had met this scenario before and how you solve it.
[Update] I've added more elements to the list and tried to run it. It did throw the same exception. I also tried reducing the amount of the elements and run again and it worked without error. So I guess it's because of the amount of element.
Private Sub generateZone(ByVal worksheet As Object)
'Initialise Excel Object
xlsApp = New Excel.Application
'Open file
xlsWorkBook = xlsApp.Workbooks.Open("File location")
'Open worksheet(according to the spreadsheet)
xlsWorkSheet = xlsWorkBook.Worksheets("sheet1")
'Excel interaction setting
With xlsApp
.Visible = True
.Application.Visible = True
.DisplayAlerts = False
.EnableEvents = False
End With
Dim emZone1 As New List(Of Integer)(New Integer() {87371, 87390, 94614, 92000, 82898, 96500, 99124, 93260, 82496, 97858, 90323, 88083, 80770, 84186, 86318, 91922, 85987, 80635, 84079, 96691, 85578, 83108, 96081, 87642, 96703, 96692, 99193, 93039, 97003, 89374, 99252, 82305, 87907, 90966, 80517, 88471, 92395, 86109, 87112, 92849, 93853, 91136, 90512, 97143, 96105, 93966, 81136, 97218, 97816, 82525, 97714, 98175, 94940, 97262, 81750, 92075, 98905, 96199, 94072, 83841, 88243, 98375, 84142, 92818, 83527, 97446, 88632, 86542, 84768, 86283, 84910, 88986, 92802, 99145, 81487, 84729, 80010, 90896, 99418, 87545, 95937, 89904, 88073, 85255, 87285, 88442, 86325, 90223, 92048, 85160, 98768, 80283, 91273, 92077, 91043, 81409, 96042, 82536, 92726, 91980})
Dim emZone2 As New List(Of Integer)(New Integer() {86634, 92330, 95970, 95577, 87510, 89481, 94248, 93860, 81857, 82810, 93228, 80095, 94437, 84887, 88766, 92706, 92264, 88109, 91992, 82751, 94767, 95397, 96066, 91667, 94059, 89419, 82796, 82310, 86961, 85681, 93969, 81736, 81009, 97445, 80741, 92154, 84923, 86182, 91660, 90665, 81388, 87722, 94031, 94678, 84074, 80550, 82953, 81317, 95132, 92163})
'get last row
Dim lastRow As Integer
lastRow = worksheet.UsedRange.Rows.Count
'loop through every row
For i As Integer = 1 To lastRow
'get pronvice from column J
Dim province As String = worksheet.Range("J" & i).Value
If province = "Sabah" Or province = "Sarawak" Then
'check zone1
For Each zone1 As Integer In emZone1
If emZone1.Contains(worksheet.Range("L" & i).Value) Then
worksheet.Range("M" & i).Value = "Zone 1"
Else
'check zone2
For Each zone2 As Integer In emZone2
If emZone2.Contains(worksheet.Range("L" & i).Value) Then
worksheet.Range("M" & i).Value = "Zone 2"
' Exception from HRESULT: 0x800AC472 shows here
Else
'if not in both zone
worksheet.Range("M" & i).Value = "EM"
End If
Next
End If
Next
Else
'if not sabah and sarawak
worksheet.Range("M" & i).Value = "WM"
End If
Next
'releaseObject(xlsWorkSheet)
'releaseObject(xlsWorkBook)
'releaseObject(xlsApp)
End Sub
Not sure if this is the same but another SO post with this same error was resolved with the following answer:
"In my case, the exception was been thrown because my excel Interop tools was displaying a modal dialog (associated with a expired licence key - shame on me). If I closed the dialog (which was been displayed in the background) and then hit 'continue' in Visual Studio, the program was able to connect to the xlsx file and retrive data succesfully."
-mbmihura
Have you verified that no popups or anything are appearing?
Is your excel licensed as well?
If not this,
I would add a limit to your loop and try to find if there is a fixed number of iterations before the error, if so, then there is some default limit being imposed.
One final thought,
I have seen these interop excel calls not get properly disposed in a lot of examples which causes many excels to be stuck running in the background.
Check your task manager and ensure that isn't happening. If so, close them out and try your tests again.
I think you just need to check for empty cells before reading the value. Excel will throw an exception when the cell is empty and you try to parse it as a string
Dim xlsRange As Excel.Range = Nothing
' In your loop
xlsRange = DirectCast(xlsWorkSheet.Cells("J" & i), Excel.Range)
If xlsRange.Value IsNot Nothing Then
Dim province = xlsRange.Value.ToString()
End If
' /Loop
' always release it at the end
If xlsRange IsNot Nothing Then Marshal.ReleaseComObject(xlRange)
I still prefer loading everything into objects and operating on them after releasing all the Excel objects
I have through an API fetched my data as an XML, and I wish to cycle through nodes (there are several of the same type) and add them to certain fields/a table.
Example from the XML-file:
<HistRating
xmlns="">
<EndrAr>2020</EndrAr>
<EndrMnd>7</EndrMnd>
<Rating>A</Rating>
</HistRating>
<HistRating
xmlns="">
<EndrAr>2019</EndrAr>
<EndrMnd>6</EndrMnd>
<Rating>A</Rating>
</HistRating>
I have tried the following format (at this point the XML I need is in a string in xmlDoc xmlDoc = CreateObject("MSXML2.DOMDocument.6.0"). Fully aware that this is not a really "sexy" way to write it, but I'm new at this game:
Set nodeXML = xmlDoc.getElementsByTagName("EndrAr")
Range("G1").Value = nodeXML(1).Text
Range("H1").Value = nodeXML(2).Text
Range("I1").Value = nodeXML(3).Text
Set nodeXML = xmlDoc.getElementsByTagName("EndrMnd")
Range("G2").Value = nodeXML(1).Text
Range("H2").Value = nodeXML(2).Text
Range("I2").Value = nodeXML(3).Text
Set nodeXML = xmlDoc.getElementsByTagName("Rating")
Range("G3").Value = nodeXML(1).Text
Range("H3").Value = nodeXML(2).Text
Range("I3").Value = nodeXML(3).Text
This works great as long as all three items are there. Unfortunately that is not given. If it is a new company i.e. (3) wont exist (there is one line per year above), and I would like to either set the cell to Blank or No value or something.
The result from when I run the above code:
But if I try to add a line 4 to test what happens if value does not exists I get the following (for obvious reasons)
What I would love some help with is:
Can I by some "magic" add a ifmissing (tried it, but could not get it to work)?
Other ways to add a if variable is not found, input following into cell
Or are there a complete different way I should have solved this?
This is to add accounting data from last X available years (where X is ie 4, or less if not 4 is available) from 30 nodes.
You could use an Error trapping Function. Note in the code below we choose not to use the returned boolean.
Dim myTest as String
.
.
TryReadingXmlNode nodeXML,1, myText
Range("G1").Value = myText
.
.
Public Function TryReadingXmlNode(ByVal ipNode as object, ByVal ipIndex as Long, ByRef opText as string) as boolean
On Error Resume Next
opText=ipNode.Item(ipIndex).Text
TryReadingXmlNode=Len(opText)>0
If err.number>0 then opText="NoValue"
on Error Goto 0
End Function
Start by querying all of the HistRating elements, then loop over that collection:
Const MAX_YEARS As Long = 4
Dim ratings, rating, c As Range, i as Long
Set c= Range("A1")
Set ratings = xmlDoc.getElementsByTagName("HistRating")
For Each rating in ratings
c.offset(0, i) = rating.getElementsByTagName("EndrAr")(0).Text
c.offset(1, i) = rating.getElementsByTagName("EndrMnd")(0).Text
c.offset(2, i) = rating.getElementsByTagName("Rating")(0).Text
i = i + 1
If i >= MAX_YEARS Then Exit For 'exit if processed enough nodes
Next rating
This is more of general question, I suppose, as-well-as help with a specific line of code.
I have an Excel file that I was working on just a few days ago that was working fine, however now whenever I try to run the macro in the workbook to pull data from a website, I receive the error "Run-time error '380': A script engine for the specified language can not be created."
Here is the code block where I am running into the issue. I have starred the specific section where the error is thrown.
Dim H As Object, S As Object, jParse As Object, X64 As Object, i&
Set H = CreateObject("WinHTTP.WinHTTPRequest.5.1")
H.SetAutoLogonPolicy 0
#If Win64 Then
Set X64 = x64Solution()
X64.execScript "Function CreateObjectx86(sProgID) Set CreateObjectx86 = CreateObject(sProgID): End Function", "VBScript"
Set S = X64.CreateObjectx86("MSScriptControl.ScriptControl")
#Else
Set S = CreateObject("ScriptControl")
#End If
***S.Language = "JScript"***
S.AddCode "function keys(O) { var k = new Array(); for (var x in O) { k.push(x); } return k; } "
I have never seen this error before and I am not sure how to fix this issue. I have looked online and have thus far been unsuccessful in figuring out the problem. I have also tried downloading and installing the zip file from Microsoft in this link: https://gallery.technet.microsoft.com/scriptcenter/Registry-key-to-re-enable-835fba77 with no success.
Any help would be appreciated, because I really don't know what to do here.
Also if Stack Overflow is not really the place for this kind of question, any help in directing me somewhere that would be better suited for this kind of problem would be appreciated.
I just had a similar encounter attempting to use JScript to parse some JSON from the SO API using a x64 machine.
Disclaimer: I did not author the following procedures, but unfortunately I do not have the source of where I obtained them either.
As you've probably already figured out, MSScriptControl.ScriptControl doesn't like the x64 architecture very well. Here are a couple of functions that will allow you to do what you need.
I placed these in a separate module:
Public Function CreateObjectx86(Optional sProgID, Optional bClose = False)
Static oWnd As Object
Dim bRunning As Boolean
#If Win64 Then
bRunning = InStr(TypeName(oWnd), "HTMLWindow") > 0
If bClose Then
If bRunning Then oWnd.Close
Exit Function
End If
If Not bRunning Then
Set oWnd = CreateWindow()
oWnd.execScript "Function CreateObjectx86(sProgID): Set CreateObjectx86 = CreateObject(sProgID): End Function", "VBScript"
End If
Set CreateObjectx86 = oWnd.CreateObjectx86(sProgID)
#Else
Set CreateObjectx86 = CreateObject(sProgID)
#End If
End Function
Private Function CreateWindow()
Dim sSignature, oShellWnd, oProc
On Error Resume Next
sSignature = Left(CreateObject("Scriptlet.TypeLib").GUID, 38)
CreateObject("WScript.Shell").Run "%systemroot%\syswow64\mshta.exe about:""about:<head><script>moveTo(-32000,-32000);document.title='x86Host'</script><hta:application showintaskbar=no /><object id='shell' classid='clsid:8856F961-340A-11D0-A96B-00C04FD705A2'><param name=RegisterAsBrowser value=1></object><script>shell.putproperty('" & sSignature & "',document.parentWindow);</script></head>""", 0, False
Do
For Each oShellWnd In CreateObject("Shell.Application").Windows
Set CreateWindow = oShellWnd.GetProperty(sSignature)
If Err.Number = 0 Then Exit Function
Err.Clear
Next
Loop
End Function
Then you can go back to your S object and set it this way:
Dim S As Object
Set S = CreateObjectx86("MSScriptControl.ScriptControl")
S.Language = "JScript"
My EXCEL VBA code builds up 1500+ instances of complex objects, always with good speed.
After all data have been processed my code cleans up, i.e. all objects and collections of them are getting set to NOTHING.
Sometimes this clean-up is fast (~10s), sometimes slow (>5 minutes).
I never start this code multiple times in the same session, i.e. I always close the workbook (all workbooks) and make sure Excel is closed.
There are no conditional formattings.
Screen updating is set to FALSE.
I use MS Office Professional Plus 2016.
Does anybody have an idea why it sometimes is fast and sometimes slow?
As some code is asked for here's the upper level clean-up loop for the superItems collection:
For idx = 1 To superItems.Count
Application.statusBar = thisFunction & ": " & superItems.Count - idx & " items left"
Set superItem = superItems(idx)
If Not (superItem Is Nothing) Then
superItem.clear
Set superItem = Nothing
End If
DoEvents
Next idx
Set superItems = Nothing
... and here's the method superItem.clear:
the superItem object holds an array (pArrTmxxItems) with pointers to item objects.
ub = UBound(pArrTmxxItems)
For idx = 0 To ub
Set item = pArrTmxxItems(idx)
If Not (item Is Nothing) Then
item.clear
Set item = Nothing
End If
Next idx
... item.clear looks like this:
the item object holds a collection pCAs of CA object instances, and (b) a collection pChildren of its own kind (i.e. aChild is of the same class as item)
If Not (pCAs Is Nothing) Then
For idx = 1 To pCAs.Count
Set CA = pCAs(idx)
If Not (CA Is Nothing) Then Set CA = Nothing 'jp171107
Next idx
Set pCAs = Nothing 'jp171107
End If
If Not (pChildren Is Nothing) Then
For idx = 1 To pChildren.Count
Set aChild = pChildren.item(idx)
aChild.clear
Set aChild = Nothing
Next idx
Set pChildren = Nothing 'jp171107
End If
Redeclare all the public variables. Every single one of them, except for the constants. Take care of the scope and do not pollute it.
Delete all the part of the code, setting stuff to nothing. The VBA Environment will do it for you. Automatically.
I am trying to create a class (named ClassSection) that contains a collection (named DefectCollection). It needs a function to add items to that collection but I'm having trouble making it work. I get Error 91 "Object variable or with block variable not set."
I have looked at the other answers on here, which is what got me this far, but I don't understand what I'm missing.
Here is the class module code:
Public DefectCollection As Collection
Private Sub Class_Initialise()
Set DefectCollection = New Collection
End Sub
Public Function AddDefect(ByRef defect As CDefect)
DefectCollection.Add defect [<---- error 91]
End Function
And here is the code that calls the function: ('defect' is another class, which works fine - I want each 'ClassSection' to be able to hold an unlimited number of 'defects')
Dim SC As Collection
Dim section As ClassSection
Set SC = New Collection
Dim SurveyLength As Double
For Each defect In DC
SurveyLength = WorksheetFunction.Max(SurveyLength, defect.Pos, defect.EndPos)
Next defect
SurveyLength = Int(SurveyLength)
For i = 0 To numSurveys
For j = 0 To SurveyLength
Set section = New ClassSection
section.ID = CStr(j & "-" & dates(i))
SC.Add Item:=section, Key:=section.ID
Next j
Next i
Dim meterage As Double
For Each defect In DC
meterage = Int(defect.Pos)
Set section = SC.Item(meterage & "-" & defect.SurveyDate)
section.AddDefect defect
Next defect
Thanks!
You get the error because the DefectCollection is Nothing. This is due to the fact that you mispelled the initalization method:
Private Sub Class_Initialise() '<-- it's with "Z", not "S"
Hence, the initialization of the class is never called, the object remain Nothing by default and the method fails when trying to add an object to Nothing