modify a macro; run macro again automatically for next cell if any error accurs

Hello every one,

i have got a macro which splits content of column D in sheet1 and make new entries in coulmn A and column B of sheet2.( Please refer to the picture and attached excel file.)

Now i want to process a very big wordlist with it. Some times this macro shows error cus of too long lenght of a string in a cell or because of other reasons. It shows sometimes " runtime error" and the macro stops.

Is it possible to modify the macro is such a way, that it starts again itself, if any error accours? That cell shoud be overjumped where the macro couldnt end its work (an error accoured) and that problem creating cell should be marked. For example "v" for successfully processed cells and "x" for those cells where the macro had stoped because of any error.

Sub test()
Dim a, b(), e, i As Long, x, y, v, s
Dim dic1 As Object, dic2 As Object
Set dic1 = CreateObject("Scripting.Dictionary")
dic1.CompareMode = vbTextCompare
Set dic2 = CreateObject("Scripting.Dictionary")
dic2.CompareMode = vbTextCompare
With Sheets("sheet1")
    a = .Range("d2", .Range("d" & Rows.Count).End(xlUp)).Value
End With
For Each e In a
    x = Split(e, ";")
    For Each v In x
        If v <> "" Then
            For Each s In x
                If (s <> "") * (s <> v) Then dic1(v) = dic1(v) & ";" & s
            Next
        End If
    Next
Next
With Sheets("sheet2")
    If Not IsEmpty(.Range("a1")) Then
        With .Range("a1").CurrentRegion.Resize(, 2)
            a = .Value
            For i = 1 To UBound(a, 1)
                If dic1.exists(a(i, 1)) Then
                    temp = a(i, 2) & dic1(a(i, 1))
                    y = Split(temp, ";")
                    For Each e In y
                        If (e <> "") * (Not dic2.exists(e)) Then
                            txt = txt & ";" & e: dic2.Add e, Nothing
                        End If
                    Next
                    a(i, 2) = Mid$(txt, 2)
                    dic1.Remove a(i, 1): dic2.RemoveAll: txt = ""
                End If
            Next
            .Value = a
        End With
    End If
    If dic1.Count > 0 Then
        ReDim b(1 To dic1.Count, 1 To 2)
        For Each e In dic1.keys
            n = n + 1: b(n, 1) = e
            For Each v In Split(dic1(e), ";")
                If (v <> "") * (Not dic2.exists(v)) Then
                    txt = txt & ";" & v: dic2.Add v, Nothing
                End If
            Next
            b(n, 2) = Mid$(txt, 2): txt = "": dic2.RemoveAll
        Next
    End If
    If n > 0 Then .Range("a" & Rows.Count).End(xlUp).Offset(1).Resize(n, 2).Value = b
    If IsEmpty(.Range("a1")) Then .Rows(1).Delete
End With
Set dic1 = Nothing: Set dic2 = Nothing
End Sub

thank you very much in advance for each assistance