Макрос удаления лишнинего текста в ячейке, и оставить нужное слово, после копирования текста из 1С в Excel

Public Sub ib()
Dim s: s = ClipboardText()
If InStr(1, s, "Сбербанк", vbTextCompare) > 0 Then ActiveCell.Value = "Сбербанк"
If InStr(1, s, "Зенит", vbTextCompare) > 0 Then ActiveCell.Value = "Зенит"
End Sub
Function ClipboardText() ' чтение из буфера обмена
    With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .GetFromClipboard
        ClipboardText = .GetText
    End With
End Function

Public Sub ib()
Dim s: s = ClipboardText()
If InStr(1, s, "Зенит", vbTextCompare) > 0 Then ActiveCell.Value = "Зенит"
If InStr(1, s, "Сбербанк", vbTextCompare) > 0 Then ActiveCell.Value = "Сбербанк"
End Sub
Function ClipboardText() ' чтение из буфера обмена
    With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .GetFromClipboard
        ClipboardText = .GetText
    End With
End Function

Sub ZiZu()
    Const TopCell As String = "J3", MaxBlank As Integer = 300
    Dim Banks: Banks = Array("Сбербанк", "Зенит", "Банк Кремлёвский", "Абсолют Банк")
 
    nBlank = 0
    i = 0
    Application.ScreenUpdating = False
    Do
        Set iRang = Range(TopCell).Offset(i, 0)
        R = iRang.Value
        i = i + 1
        If IsEmpty(R) Then
            nBlank = nBlank + 1
        Else
            nBlank = 0
            For Each Bank In Banks
                If InStr(1, R, Bank, 1) > 0 Then
                    iRang.Value = Bank
                    Exit For
                End If
            Next
        End If
    Loop Until nBlank >= MaxBlank
    Application.ScreenUpdating = True
End Sub