Excel VBA: Infos automatisch aus html Datei suchen und in Excel einfügen

Sub ImportHTML()
    'Pfad mit den HTML Dateien  
    pfad = "C:\htmldateien"  
    'Zielworksheet festlegen  
    Set ws = Worksheets(1)
    'Startzelle setzen  
    Set rngCurrent = ws.Range("A1")  
    'Objekte erzeugen  
    Set fso = CreateObject("Scripting.FilesystemObject")  
    Set regex = CreateObject("VBScript.Regexp")  
    'Eigenschaften für regex setzen  
    regex.IgnoreCase = True
    regex.Global = True
    'HTML Dateien im Verzeichnis auflisten  
    f = Dir(pfad & "\*.html")  
    While f <> ""  
        ' Inhalt der Datei holen  
        strContent = fso.OpenTextfile(pfad & "\" & f, 1).ReadAll()  
        'Regex Pattern zum extrahieren der gewünschten Fragmente  
        regex.Pattern = "<h1 id=""eine_var1"">([\s\S]*?)</h1>[\s\S]*<span id=""eine_var2"" style=""color:(Blue|Yellow);"">([\s\S]*?)</span>[\s\S]*ladeWert\(\{([^}]*)[\s\S]*festerbegriff"":\[(\{[^\]]*\})"  
        'Regex ausführen  
        Set matches = regex.Execute(strContent)
        If matches.Count > 0 Then
            'Regex Submatches Variablen zuweisen  
            strPart1 = matches(0).submatches(0)
            strPart2 = matches(0).submatches(2)
            strPart3 = matches(0).submatches(3)
            strPart4 = matches(0).submatches(4)
            
            'Ersten Wert schreiben  
            rngCurrent.Value = strPart1
            'Zweiten Wert schreiben  
            rngCurrent.Offset(0, 1).Value = strPart2
            
            ' Erstes Javascript Array auslesen  
            col = 2
            arr = Split(strPart3, ",", -1, vbTextCompare)  
            For i = 0 To UBound(arr)
                wert = Split(arr(i), ":", 2, vbTextCompare)(1)  
                rngCurrent.Offset(0, col).Value = Trim(wert)
                col = col + 1
            Next
            
            'zweites JavaScript Array auslesen  
            regex.Pattern = """text"":""(.*?)"",""da"":""(.*?)"""  
            Set matches = regex.Execute(strPart4)
            If matches.Count > 0 Then
                For Each Match In matches
                    rngCurrent.Offset(0, col).Value = Match.submatches(0)
                    rngCurrent.Offset(0, col + 1).Value = Match.submatches(1)
                    col = col + 2
                Next
            End If
        End If
        ' nächste Datei  
        f = Dir
        ' aktuelle Zelle eins nach unten verschieben  
        Set rngCurrent = rngCurrent.Offset(1, 0)
    Wend
    
    Set fso = Nothing
    Set regex = Nothing
End Sub