The code below extracts data from one web page - I emulate search, select all results from the list and when the list appears (42000 items) I loop through these items.
I get an id value from their href to create a proper link (example href
is href="javascript:NeuFenster('rb_id=570964&land_abk=bw'
, so I don't want any JS interaction while I can just create working links). Then I navigate to this link and extract whole text from last table row.
The main reason that I post this code is a memory issue. From all my testing here is what happens:
iexplore.exe
process starts for the main result page, with a helper 32 bitiexplore.exe
*32;- memory used by
iexplore.exe
*32 increases up to 308 MB and when result page is fully loaded, it remains +/- 2MB constant through whole extraction process; - when a popup window (subpage for each result) is open, another
iexplore.exe
*32 opens, but unlike in the previous process, its memory usage never stops increasing, despitePopUpWindow.Quit
andset PopupWindow = nothing
; - a third
iexplore.exe
process starts once first pop-up window is open, it has a constant memory usage around 24 MB. I have a problem understanding why such process appears at all; - each time I have scraped around 6000 elements, IE automation error appears. I have concluded that maybe it's because at this point all
iexplore.exe
*32 processes together consume around 500MB of memory, maybe it's some limit. - when I run this macro on other old PC, which has hardly any free RAM, automation errors appear usually around 10 times faster and therefore using this macro is impossible on that PC.
Is there any way to stop this increasing memory usage? Maybe I should set IHTMLElement
objects to nothing as well?
Are there any other things which could be upgrade efficiency / transparency of the code (apart from moving code to a module, applying multithreading and using XML)?
Option Explicit
Private Sub CommandButton1_Click()
Dim htmlele As IHTMLElement, htmlele2 As IHTMLElement
Dim ie As Object, PopupWindow As Object
Dim Link As String, LinkID As String
Dim i As Long
Dim ws As Worksheet
'Dim TimeCount As Double
Set ws = ThisWorkbook.Sheets("results")
With ws
Application.StatusBar = False
Application.ScreenUpdating = False
Application.DisplayStatusBar = True
Link = "https://www.handelsregisterbekanntmachungen.de/?aktion=suche#Ergebnis"
Set ie = CreateObject("InternetExplorer.Application")
ie.Navigate Link
'ie.Visible = True
Do Until ie.ReadyState = 4 And ie.Busy = False
DoEvents
Loop
'click on search button, search criteria are default
For Each htmlele In ie.document.getElementsByTagName("input")
If htmlele.Value = "Suche starten" Then
htmlele.Click
Do Until ie.ReadyState = 4 And ie.Busy = False
DoEvents
Loop
Exit For
End If
Next htmlele
'find the "big" dropdown list with > 100 items, choose "all" and fire on change event to get all results listed
For Each htmlele In ie.document.getElementsByTagName("select")
If htmlele.Children.Length > 100 Then
htmlele.Value = "all"
htmlele.selectedIndex = htmlele.Children.Length - 1
htmlele.FireEvent ("onchange")
Exit For
End If
Next htmlele
Do Until ie.ReadyState = 4 And ie.Busy = False
DoEvents
Loop
i = 1
'TimeCount = Timer
For Each htmlele In ie.document.getElementsByTagName("a")
If InStr(htmlele.href, "javascript:NeuFenster") <> 0 Then
If htmlele.textContent <> vbNullString Then
i = i + 1
LinkID = Mid(htmlele.href, InStr(htmlele.href, "id=") + 3, 6)
Link = "https://www.handelsregisterbekanntmachungen.de/skripte/hrb.php?rb_id=" & LinkID & "&land_abk=bw"
Set PopupWindow = CreateObject("InternetExplorer.Application")
PopupWindow.Navigate Link
'PopupWindow.Visible = True
Do Until PopupWindow.ReadyState = 4 And PopupWindow.Busy = False
DoEvents
Loop
For Each htmlele2 In PopupWindow.document.getElementsByTagName("tbody")
.Range("a" & i).Value = htmlele2.Children(htmlele2.Children.Length - 1).textContent
Next htmlele2
PopupWindow.Quit
Set PopupWindow = Nothing
'update status bar every 100 items
If i Mod 100 = 0 Then Application.StatusBar = i
End If
End If
Next htmlele
End With
ie.Quit
'Debug.Print Timer - TimeCount
Application.ScreenUpdating = True
Application.StatusBar = False
Exit Sub
End Sub