Category Archives: Excel and VBA

Webscraping gegevens ophalen van een webpagina

Excel and VBA

Oorspronkelijk geplaatst op:

Snel gegevens ophalen van het web ook wel webscraping genoemd. We surfen daarvoor naar:

https://www.autoscout24.de/lst/ford/granada?sort=standard&desc=0&ustate=N%2CU&atype=C&cy=D&ocs_listing=include&source=homepage_search-mask

en willen de prijzen van de old-timer Ford Granada downloaden. Simpel. Onderstaande code kopiëren en in een moduleblad plakken en op F5 slaan. We halen de title en de prijs op.

Lees onderstaande rode gedeelte goed

‘*****************************************************
‘Geef een verwijzing op naar:
‘Microsoft HTML Object Library
‘Te bereiken via: Alt+F11 | Extra | Verwijzingen
‘*****************************************************

Option Explicit

'Tools->Refernces Microsoft HTML Object Library

'MSDN - URLDownloadToFile function - https://msdn.microsoft.com/en-us/library/ms775123(v=vs.85).aspx
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
(ByVal pCaller      As Long, ByVal szURL As String, ByVal szFileName As String, _
ByVal dwReserved    As Long, ByVal lpfnCB As Long) As Long

Sub Find_Ford_Granada()
    
    Dim fso         As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Dim sLocalFilename As String
    sLocalFilename = Environ$("TMP") & "\urlmon.html"
    
    Dim sURL        As String
    sURL = "https://www.autoscout24.de/lst/ford/granada?sort=standard&desc=0&ustate=N%2CU&atype=C&cy=D&ocs_listing=include&source=homepage_search-mask"
    
    Dim bOk         As Boolean
    bOk = (URLDownloadToFile(0, sURL, sLocalFilename, 0, 0) = 0)
    If bOk Then
        If fso.FileExists(sLocalFilename) Then
            
            'Tools->References Microsoft HTML Object Library
            Dim oHtml4 As MSHTML.IHTMLDocument4
            Set oHtml4 = New MSHTML.HTMLDocument
            
            Dim oHtml As MSHTML.HTMLDocument
            Set oHtml = Nothing
            
            'IHTMLDocument4.createDocumentFromUrl
            'MSDN - IHTMLDocument4 createDocumentFromUrl method - https://msdn.microsoft.com/en-us/library/aa752523(v=vs.85).aspx
            Set oHtml = oHtml4.createDocumentFromUrl(sLocalFilename, "")
            
            'need to wait a little whilst the document parses
            'because it is multithreaded
            While oHtml.readyState <> "complete"
                DoEvents        'do not comment this out it is required to break into the code if in infinite loop
            Wend
            Debug.Assert oHtml.readyState = "complete"
            
            Dim sTest As String
            sTest = Left$(oHtml.body.outerHTML, 100)
            Debug.Assert Len(Trim(sTest)) > 50        'just testing we got a substantial block of text, feel free to delete
            
            'You can log the information in a textfile. Uncheck the next line.
            'LogInformation (oHtml.body.outerHTML)
            
            'this is where the page specific logic now goes, here I am getting info from Autoscout page
            
            Dim htmlBrand As Object        'MSHTML.DispHTMLElementCollection
            Dim htmlPrice As Object        'MSHTML.DispHTMLElementCollection
            Set htmlBrand = oHtml.getElementsByTagName("h2")
            Set htmlPrice = oHtml.getElementsByClassName("CurrentPrice_price__Ekflz")
            
            Dim lngCounterLoop As Long
            For lngCounterLoop = 0 To htmlBrand.Length - 1
                Dim vBrand
                Dim vPrice
                Set vBrand = htmlBrand.Item(lngCounterLoop)
                Set vPrice = htmlPrice.Item(lngCounterLoop)
                
                'On Error GoTo err_chk
                If vBrand Is Nothing Or vPrice Is Nothing Then
                    Debug.Print "There are no more car brands Or prices To be found Or available"
                Else
                    Debug.Print vBrand.outerText & " - " & vPrice.outerText
                End If
                'On Error GoTo 0
            Next
        End If
    End If
    
    'err_chk:
    '   If Err.Number = 91 Then
    '      MsgBox "There was an ERROR!!! - " & Err.Number & " :  " & Err.Description & vbNewLine & "There are no more brand or price for cars available"
    ' Else
    '    MsgBox Err.Number & ":" & Err.Description
    'End If
End Sub

Het resultaat in het zogenaamde immediate window (als je dit window niet ziet, te bereiken via sneltoets Ctrl+G of via View | Immediate window)

Ford Granada 2.8 i V6 Ghia Turnier Klima – SSD- 5.Gang – € 4.890
Ford Granada L – € 7.999
Ford Granada – € 2.500
Ford Granada Dorchester – € 7.999
Ford Granada I Coupé 1.7 V4 nur 67 TKMHU neuH-Zulassung – € 9.450
Ford Granada 2,8i GhiaVOLL-RESTAURIERT – € 18.300
Ford Granada – € 5.290
Ford Granada US Modell 76er Oldtimer H-Kennzeichen 5.0 V8 – € 7.900
Ford Granada GL-GHIA SERVO/SCHIEBEDACH – € 14.900
Ford Granada MK 2 – 2,0 Automatik – erst 78000 Km. – € 7.800
Ford Granada 2.3 Ghia Automatic 2.Hdn. 86 TKM – € 16.500
Ford Granada |H-Kennzeichen|Scheckheft|Klima|AHK – € 9.970
Ford Granada Granada GL / V6 2,0 Motor / 1 HAND – € 4.000
There are no more car brands or prices to be found or available

When you want to log the information in a textfile. Uncheck the next line.
‘LogInformation (oHtml.body.outerHTML)
In the code above and put the code below in the module.

Sub LogInformation(LogMessage As String)

    Dim fileNum As Integer
    Const LogFileName As String = "C:\temp\textfile.html"

    Open "C:\temp\textfile.html" For Output As #1
    Close #1
    MsgBox "Clear complete"

    fileNum = FreeFile                                ' next file number
    Open LogFileName For Append As #fileNum           ' creates the file if it doesn't exist
    Print #fileNum, LogMessage                        ' write information at the end of the text file
    Close #fileNum                                    ' close the file

End Sub

Hoe vaak komt dat woord voor

Excel and VBA

Oorspronkelijk geplaatst op:

Hoe vaak komt een woord voor in een tekst? Ik zou niet weten waarom je dat zou willen weten. Maar met Excel kun je zoiets berekenen.
In afbeelding 1 zie je in Cel A1 en A2 een paar zinnen uit de welbekende Lorem Ipsum tekst.

AFBEELDING 1

In Afbeelding 2 zie je een gedeelte van het resultaat.
AFBEELDING 2

De VBA code die je kunt gebruiken.
LET OP, de eerste code is hoofdletter gevoelig. Dat betekent dat bijvoorbeeld het woord “nulla” anders is als het woord “Nulla”. Beide woorden komen daarom 2x voor.

Option Explicit

Sub Hoe_Vaak_Komt_Dat_Woord_Voor()
'Zet Data in meerdere cellen van Kolom A.
'Data alleen in A1 geeft foutmelding

Dim x As Long, Cnt As Long, Txt As String, Arr() As String
    Txt = " " & Join(Application.Transpose(Range([A1], Cells(Rows.Count, "A").End(xlUp)))) & " "
    
    For x = 2 To Len(Txt)
        If Mid(Txt, x, 1) = "'" And Not Mid(Txt, x - 1, 3) Like "[A-Za-z0-9]'[A-Za-z0-9]" Then
            Mid(Txt, x) = " "
        ElseIf Mid(Txt, x, 1) Like "[!A-Za-z0-9']" Then
            Mid(Txt, x) = " "
        End If
    Next
    
    Arr = Split(Application.Trim(Txt))
    
    With CreateObject("scripting.dictionary")
        
        For x = 0 To UBound(Arr)
            .Item(Arr(x)) = .Item(Arr(x)) + 1
        Next
        
        Cnt = .Count
        Range("C2").Resize(Cnt) = Application.Transpose(.Keys)
        Range("D2").Resize(Cnt) = Application.Transpose(.items)
    End With
    
    Range("C2:D" & Cnt).Sort Range("C2"), xlAscending, Range("D2"), , xlDescending, Header:=xlNo, MatchCase:=False
End Sub

LET OP, de tweede code is NIET hoofdletter gevoelig. Dat betekent dat bijvoorbeeld het woord “nulla” hetzelfde is als het woord “Nulla” en daarom 4x voor komt.

Sub Hoe_Vaak_Komt_Dat_Woord_Voor_Met_RegExp()
'Data in Kolom A, resultaat komt in de Kolommen F:G.
'*****************************************************
'Geef een verwijzing op naar:
'Microsoft Forms 2.0 Object Library
'Te bereiken via: Alt+F11 | Tools | References
'*****************************************************

Dim regEx As Object, matches As Object, x As Object, d As Object
Dim obj As New DataObject
Dim tx As String, z As String

    Range("A1", Cells(Rows.Count, "A").End(xlUp)).Copy
    obj.GetFromClipboard
    tx = obj.GetText
    Application.CutCopyMode = False
    tx = Replace(tx, "'", "___")
        
    Set regEx = CreateObject("VBScript.RegExp")
    
    With regEx
        .Global = True
        .MultiLine = True
        .IgnoreCase = True
        .Pattern = "\w+"
    End With
    
    Set d = CreateObject("scripting.dictionary")
    d.CompareMode = vbTextCompare
        
    Set matches = regEx.Execute(tx)
            
        For Each x In matches
            z = CStr(x)
            If Not d.Exists(z) Then
                d(z) = 1
            Else
                d(z) = d(z) + 1
            End If
        Next
                    
    If d.Count = 0 Then MsgBox "Nothing found": Exit Sub
    Range("D:E").ClearContents
    
    'put the result in col D:E
        With Range("F2").Resize(d.Count, 2)
            .Cells = Application.Transpose(Array(d.Keys, d.items))
            .Replace What:="___", Replacement:="'", LookAt:=xlPart, SearchFormat:=False, ReplaceFormat:=False
        End With
    'Sort
    Range("F2:G" & d.Count).Sort Range("F2"), xlAscending, Range("G2"), , xlDescending, Header:=xlNo, MatchCase:=False
End Sub

Vind de hoogste waarde van een bedrijf

Excel and VBA

Oorspronkelijk geplaatst op:

In Kolom A staan bedrijven. Sommige bedrijven staan er meerdere keren in. We hebben dus te maken met dubbele waarden in kolom A

We willen in dit voorbeeld de HOOGSTE waarde van Hasbro, Inc.
In D2 kun je een validatielijst maken met alle namen van de bedrijven zodat je gemakkelijk een bedrijf kunt selecteren.

Om dat te doen maak je ergens op je werkblad eerst een unieke lijst met alle bedrijven, Bijvoorbeeld in F2:F14.

Data | Data validation | Data validation | Allow > List | Source > en verwijs naar F2:F14

In D5 komt de formule:
=MAX(INDEX((A2:A21=D2)*B2:B21;0))