Do While по двум условиям

[Questru]

Всем привет
Не могу осилить...

Есть наполнение ячейки:
Фамилия1 Имя1;#122;#Фамилия2 Имя2;#53;#Фамилия3 Имя3;#437;#Фамилия4 Имя4;#110

Нужно выбросить из ячейки то, что стоит после # и до следующей фамилии ну и в самом конце просто убрать точку с запятой, хэштег и цифры

То есть должно получиться вот такое:
Фамилия1 Имя1;Фамилия2 Имя2;Фамилия3 Имя3;Фамилия4 Имя4

Есть вот такой код:

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

    For i = 3 To n
        Length = Len(Cells(i, 3))
        ReDim String_Array(1 To Length)
        For k = 1 To Length
            If Mid(Cells(i, 3), k, 1) <> "#" Then
                String_Array(k) = Mid(Cells(i, 3), k, 1)
            Else
                Do While z <> "#" Or k > Length
                    k = k + 1
                    z = Mid(Cells(i, 3), k, 1)
                Loop
            End If
        Next k
        Cells(i, 3) = ""
        For t = 1 To Length
            Cells(i, 3) = Cells(i, 3) + String_Array(t)
        Next t
    Next i

Код при исполнении убегает в бесконечность. Понимаю, что где-то косячу в условиях для While, но где понять не могу...
Помогите, пожалуйста.

Спасибо!

[Questru]

Изменил код вот так

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

    For i = 3 To n
        Length = Len(Cells(i, 3))
        ReDim String_Array(1 To Length)
        For k = 1 To Length
            If Mid(Cells(i, 3), k, 1) <> "#" Then
                String_Array(k) = Mid(Cells(i, 3), k, 1)
            Else
                Do While z <> "#"
                    k = k + 1
                    z = Mid(Cells(i, 3), k, 1)
                    If z = "" Then Exit Do
                Loop
            End If
        Next k
        Cells(i, 3) = ""
        For t = 1 To Length
            Cells(i, 3) = Cells(i, 3) + String_Array(t)
        Next t
    Next i

В бесконечно не убегает, но цифры не удаляет...

[Aleksandr H.]

Вариант без While

Function ClearCell(sValue As String)
    Dim s() As String
    Dim i As Integer
    Dim sResult As String, sCell As String
    sResult = vbNullString
    
    s = Split(sValue, "#")
    For i = LBound(s) To UBound(s)
        sCell = Trim(s(i))
        If Len(sCell) > Len(Replace(sCell, " ", "")) Then
            sResult = sResult & " " & sCell
        End If
    Next i
    ClearCell = Left(sResult, Len(sResult) - 1)
End Function

[Questru]

Шик блеск красота!
Спасибо большое!

Только стал добавляться пробел в начало строки.
Я чутка изменил вот так:

Function ClearCell(sValue As String)
    Dim s() As String
    Dim i As Integer
    Dim sResult As String, sCell As String
    sResult = vbNullString

    s = Split(sValue, "#")
    For i = LBound(s) To UBound(s)
        sCell = Trim(s(i))
        If Len(sCell) > Len(Replace(sCell, " ", "")) Then
            sResult = sResult & sCell
        End If
    Next i
    ClearCell = Left(sResult, Len(sResult) - 1)
End Function

Теперь то что надо!