Excel reagiert nicht mehr bem Ausführen eines Makros

Sub old()

    Dim ws As Worksheet

    Dim http As Object

    Dim html As Object

    Dim objLinks As Object

    Dim objLink As Object

    Dim lngCount As Long

    Dim lloRow As Long

    Dim lastRow As Long

    Dim wsNames As Variant

    Dim i As Integer

    Dim totalRows As Long

    Dim processedRows As Long

    Dim progressPercent As Single

    

    ' Tabellen in einem Array speichern

    wsNames = Array("Tabelle1", "Tabelle2")

    

    ' HTTP-Objekt erstellen

    Set http = CreateObject("MSXML2.XMLHTTP")

    

    Application.ScreenUpdating = False

    Application.Calculation = xlCalculationManual

    

    ' Berechne die Gesamtanzahl der zu verarbeitenden Zeilen (URLs) in beiden Blättern

    totalRows = 0

    For i = LBound(wsNames) To UBound(wsNames)

        Set ws = ThisWorkbook.Worksheets(wsNames(i))

        totalRows = totalRows + ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

    Next i

    

    processedRows = 0 ' Zähler für verarbeitete Zeilen

    

    ' Schleife durch alle Tabellen in wsNames

    For i = LBound(wsNames) To UBound(wsNames)

        ' Setze das Arbeitsblatt auf die aktuelle Tabelle

        Set ws = ThisWorkbook.Worksheets(wsNames(i))

        

        ' Letzte Zeile in Spalte A ermitteln

        lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

        

        ' Beginne bei der ersten Zeile in Spalte B

        lngCount = 1

        

        ' Schleife durch alle URLs in Spalte A

        For lloRow = 1 To lastRow

            ' URL aus Zelle A einlesen

            http.Open "GET", ws.Range("A" & lloRow).Text, False

            http.Send

            

            ' Überprüfen, ob die Seite erfolgreich geladen wurde

            If http.Status = 200 Then

                ' HTML-Dokument erstellen und laden

                Set html = CreateObject("HTMLFile")

                html.body.innerHTML = http.responseText

                

                ' Links im HTML-Dokument durchsuchen

                Set objLinks = html.getElementsByTagName("a")

                

                ' Schleife durch alle Links und liste sie in Spalte B und C auf

                If objLinks.Length > 0 Then

                    For Each objLink In objLinks

                        ws.Cells(lngCount, 2).Value = objLink.href    ' Hyperlink in Spalte B

                        ws.Cells(lngCount, 3).Value = "'" & objLink.innerText   ' Hyperlink-Text in Spalte C

                        lngCount = lngCount + 1

                    Next objLink

                End If

            End If

            

            ' Fortschritt berechnen und anzeigen

            processedRows = processedRows + 1

            progressPercent = (processedRows / totalRows) * 100

            Application.StatusBar = "Fortschritt: " & Format(progressPercent, "0.00") & "% - Verarbeite Tabelle " & wsNames(i) & ", Zeile " & lloRow & " von " & lastRow

        Next lloRow

    Next i

    

    ' Nach der Verarbeitung aller Blätter alle Berechnungen aktualisieren

    Application.Calculation = xlCalculationAutomatic

    

    ' Aufräumen

    Set http = Nothing

    Set html = Nothing

    

    ' Statusleiste zurücksetzen und Bildschirmaktualisierung wieder aktivieren

    Application.StatusBar = False

    Application.ScreenUpdating = True

End Sub