plötzlich keine Rückmeldung von Excel mehr bei Makro

Sub UpdateUmwandeln()

    Dim wsUpdate As Worksheet

    Dim letzteZeileUpdate As Long

    Dim deleteStartRow As Long

    Dim cell As Range

    Dim formulaRange As Range

    

    Set wsUpdate = ThisWorkbook.Sheets("Update") ' Anpassen falls nötig

    letzteZeileUpdate = wsUpdate.Cells(wsUpdate.Rows.count, 1).End(xlUp).Row

    

    ' Alle Shapes auf einmal löschen

    On Error Resume Next

    wsUpdate.Shapes.SelectAll

    Selection.Delete

    On Error GoTo 0

    

    ' Hyperlinks extrahieren und Werte in Spalte B einfügen

    For Each cell In wsUpdate.Range("A1:A" & letzteZeileUpdate)

        If cell.Hyperlinks.count > 0 Then

            Dim HyAddressParts() As String

            Dim partBeforeDot As String

            partBeforeDot = Split(cell.text, ".")(0)

            

            If IsNumeric(partBeforeDot) And Val(partBeforeDot)  1001 Then

                HyAddressParts = Split(cell.Hyperlinks(1).Address, "/")

                If UBound(HyAddressParts) >= 4 Then cell.Offset(0, 1).Value = HyAddressParts(5)

            End If

        End If

    Next cell

    

    ' Sortieren und überflüssige Zeilen löschen

    wsUpdate.Range("A1:B" & letzteZeileUpdate).Sort Key1:=wsUpdate.Range("B1"), Order1:=xlAscending, Header:=xlNo

    deleteStartRow = wsUpdate.Cells(wsUpdate.Rows.count, 2).End(xlUp).Row + 1

    If letzteZeileUpdate >= deleteStartRow Then wsUpdate.Rows(deleteStartRow & ":" & letzteZeileUpdate).Delete

    

    ' Zwei Spalten einfügen

    wsUpdate.Columns("B:C").Insert Shift:=xlToRight

    

    ' Direkte Formelzuweisung und Umwandlung

    Set formulaRange = wsUpdate.Range("B1:B" & deleteStartRow - 1)

    formulaRange.Formula = "=TRIM(SUBSTITUTE(A1, "". "", ""~"", 1))"

    formulaRange.Value = formulaRange.Value ' Formeln in Werte umwandeln

    formulaRange.TextToColumns Destination:=formulaRange, DataType:=xlDelimited, Other:=True, OtherChar:="~"

    

    ' Spalte A löschen und Spaltenbreite anpassen

    wsUpdate.Columns("A").Delete

    wsUpdate.Columns.AutoFit

    

    ' Finale Sortierung

    letzteZeileUpdate = wsUpdate.Cells(wsUpdate.Rows.count, 1).End(xlUp).Row

    wsUpdate.Range("A1:C" & letzteZeileUpdate).Sort Key1:=wsUpdate.Range("B1"), Order1:=xlAscending, Header:=xlNo

    

End Sub

Dim shp As Shape

For Each shp In wsUpdate.Shapes

    shp.Delete

Next shp