Web Scrap on Chrome via VBA

[Emka]

Hallo allemaal, ik heb een probleem met het uitlezen van een Genealogische website.
Hier van kan ik slechts een deel van de personen per familienaam uitlezen.
Het blijkt dat er per blad 3 sets namen met elk 10 personen. Bij meer dan 10 personen volgt er een vervolgblad.
De eerste set kan ik uitlezen, de rest niet. Geprobeerd met een twee loop maar ook dat lukt niet.
Ik lees de namen via een For-Next uit een Excel-lijst op blad "K" (bijvoorbeeld) met de voorkomende familienamen.

Hello everyone, I have a problem reading a Genealogical website.
I can only read a part of the persons per family name.
It appears that there are 3 sets of names per sheet with 10 persons each. With more than 10 persons there is a follow-up sheet.
I can read the first set, but not the rest. Tried with a second loop but that does not work either.
I read the names via a For-Next from an Excel list on sheet "K" (for example) with the occurring family names.

Sub Extract_Personen() 'Genealogische Databank Vlaardingen » Persons with the same Family-Name ??
    'voor "Immediate Window" (Direct) gebruik CTRL + G t.b.v. Debug.Print "...." & value
    'https://www.genealogieonline.nl/genealogische-databank-vlaardingen/familienamen.php?letter=K&p=1
    Dim URL As String
    Dim ie As Object 'InternetExplorer
    Dim HTMLdoc As HTMLDocument
    Dim R As Integer
    Dim kar(1 To 9999) As String
    Dim Ask(1 To 9999) As String
    Dim I As Integer
    Dim N As Integer
    I = 0
    N = Sheets("K").Cells(1, 2).Value 'Number family-members
    S = 1 'schrijflijn
    For I = 2 To N
        ' Set the URL of the website to scrape
        URL = Sheets("K").Cells(I, 1).Hyperlinks(1).Address 'Link family-Name from table
        Set ie = CreateObject("InternetExplorer.Application")
        With ie
            .navigate URL
            '.Visible = True
            'Wait for page to load
            Do While ie.Busy Or ie.readyState <> 4
                DoEvents
            Loop
            Set HTMLdoc = .Document
        End With
    
        'Set DIVelements = HTMLdoc.getElementsByClassName("row")
        Set ULelements = HTMLdoc.getElementsByTagName("ul")
        LengteDIV = Len(DIVelements)
        LengteUL = Len(ULelements)

        'THIS LOOP TEMPERLY CLOSED
        'N = 0
        'For Each DIVelement In DIVelements
            'If DIVelement.className = "row" Then
        
        R = 0
        For Each ulElement In ULelements
            If ulElement.className = "nicelist" Then
                If R = 0 Then
                    'Debug.Print ULelement.innerText 'all names
                    Ask10 = 0 ': I = 0
                    TextHTML = ulElement.innerHTML
                    Textblok = ulElement.innerText
                    Lengte = Len(ulElement.innerText)
                    Lengte2 = Len(Textblok)
                    'TEXSTBLOK FIND FOR LINEFEED 'Zoeken naar linefeed
                    For J = 1 To Lengte
                        kar(J) = Mid(Textblok, J, 1): Ask(J) = Asc(kar(J))
                        If Ask(J) = 10 Then
                            Ask10 = Ask10 + 1
                        End If
                    Next J
                    'TEXSTBLOK SLIT-UP into LINES 'OPDELEN IN REGELS
                    Begin = 0: Einde = 0: Regel = 0
                    Text = ulElement.innerText
                    LF = Chr(10): Sp = Chr(32) 'Linefeed & Space
                    For L = 1 To Ask10
                        Lijn = Left(Text, (InStr(1, Text, LF, vbTextCompare) - 1))
                        Cells(S, 1) = Lijn
                        Text = Right(Text, Len(Text) - Len(Lijn) - 1)
                        LLijn = Len(Lijn) - 1 'lengte lijn min LF
                        FLH = InStr(1, Lijn, "(", vbBinaryCompare)          'First Left Haakje
                        SLH = InStr(FLH + 1, Lijn, "(", vbBinaryCompare)    'Second Left Haakje
                        FRH = InStr(1, Lijn, ")", vbBinaryCompare)          'First Right Haakje
                        SRH = InStr(FRH + 1, Lijn, ")", vbBinaryCompare)    'Second Right Haakje
                        If SRH > 0 Then
                            Ldat = InStr(LLijn - 11, Lijn, "(", vbBinaryCompare) 'Aanvang Datum
                            Sdat = LLijn - Ldat + 2
                        End If
                        If SRH > 0 Then
                            name = Left(Lijn, SLH - 2): Cells(S, 2) = name
                            Datum = Right(Lijn, LLijn - SLH + 2): Cells(S, 3) = Datum
                        ElseIf FLH = 0 Then
                            name = Lijn: Cells(S, 2) = name
                            'Geen Datums
                        ElseIf (FLH > 0) And (InStr(FLH, Lijn, "-", vbBinaryCompare) > 0) Then
                            name = Left(Lijn, FLH - 2): Cells(S, 2) = name
                            Datum = Right(Lijn, LLijn - FLH + 2): Cells(S, 3) = Datum
                        ElseIf (FLH > 0) And (InStr(FLH, Lijn, "-", vbBinaryCompare) = 0) Then
                            name = Lijn: Cells(S, 2) = name
                            'Geen Datums
                        ElseIf (FLH = 0) Then
                            name = Lijn: Cells(S, 2) = name
                            'Geen Datums
                        End If
                        R = R + 1 'Aantal fam.leden
                        S = S + 1 'Schrijfregel
                        FLH = 0: SLH = 0: FRH = 0: SRH = 0: name = "": Datum = "" 'resetten
                    Next L
                    'Latest Name without linefeed 'laatste is zonder linefeed
                    Lijn = Text
                    Cells(S, 1) = Text & "*" 'STERRETJE voor laaste persoon
                    LLijn = Len(Lijn)
                    FLH = InStr(1, Lijn, "(", vbBinaryCompare)          'First Left Haakje
                    SLH = InStr(FLH + 1, Lijn, "(", vbBinaryCompare)    'Second Left Haakje
                    TLH = InStr(TLH + 1, Lijn, "(", vbBinaryCompare)    'Thirt Left Haakje
                    FRH = InStr(1, Lijn, ")", vbBinaryCompare)          'First Right Haakje
                    SRH = InStr(FRH + 1, Lijn, ")", vbBinaryCompare)    'Second Right Haakje
                    TRH = InStr(TRH + 1, Lijn, ")", vbBinaryCompare)    'Thirt Right Haakje
                
                    If SRH > 0 Then
                        Ldat = InStr(LLijn - 11, Lijn, "(", vbBinaryCompare) 'Aanvang Datum
                        Sdat = LLijn - Ldat + 2
                    End If
                    If SRH > 0 Then
                        name = Left(Lijn, SLH - 2): Cells(S, 2) = name
                        Datum = Right(Lijn, LLijn - SLH + 1): Cells(S, 3) = Datum
                    ElseIf FLH = 0 Then
                        name = Lijn: Cells(S, 2) = name
                        'Geen Datums
                    ElseIf (FLH > 0) And (InStr(FLH, Lijn, "-", vbBinaryCompare) > 0) Then
                        name = Left(Lijn, FLH - 2): Cells(S, 2) = name
                        Datum = Right(Lijn, LLijn - FLH + 1): Cells(S, 3) = Datum
                    ElseIf (FLH > 0) And (InStr(FLH, Lijn, "-", vbBinaryCompare) = 0) Then
                    name = Lijn: Cells(S, 2) = name
                    'Geen Datums
                    ElseIf (FLH = 0) Then
                        name = Lijn: Cells(S, 2) = name
                        'Geen Datums
                    End If
                    R = R + 1 'Aantal fam.leden
                    S = S + 1 'Schrijfregel
                    FLH = 0: SLH = 0: FRH = 0: SRH = 0: name = "": Datum = "" 'resetten
                    Debug.Print ULelements & " Number of fam.members = " & R & " Number of karakters=" & Lengte2
                    ' MsgBox "Next L " & L & " " & Name & " - " & Datum & " R=" & r
                    If R = 10 Then
                        MsgBox "There are more family members ! but not printed" 'Er zijn meer familieleden !
                    End If 'R = 10
                End If 'R
            End If 'ul = nicelist
            'MsgBox "Number = " & r - 1
        Next 'Each ULelement
    'End If 'div = col-md-4
    'N = N + 1: 'Stop
    'Next 'Each DIVelement

    ie.Quit
  'MsgBox "Next Family-name" & "number " & I
  Next 'I
    ' Notify the user that the data has been successfully exported
    MsgBox "Data has been exported to Excel.", vbInformation
End Sub