Const myRange = "E5:M24"

Sub poisk()
Dim YourRange As Range, iFoundRng As Range, k As Long
Dim firstAddress As String, findDan As String, arrZam

Set YourRange = Range(myRange)
'Set YourRange = Application.InputBox _
'        (Prompt:="Выделите диапазон ячеек", _
'        Title:="", Type:=8)
'If YourRange Is Nothing Then MsgBox "Выберите диапазон, а то ни чего делать не буду", vbInformation, "НУ?!"

findDan = "д"
arrZam = Split("1~2~3~4~5", "~")
k = UBound(arrZam) + 1
If Not YourRange Is Nothing Then
            Set iFoundRng = YourRange.Find(What:=findDan, LookIn:=xlFormulas, LookAt:=xlWhole) 'поиск
            If Not iFoundRng Is Nothing Then 'если нашли
                firstAddress = iFoundRng.Address 'запоминаем адрес найденной ячейки, чтобы продолжить поиск по листу
                iFoundRng.Offset(, 1).Resize(, k).Value = arrZam
                
                
                'Debug.Print firstAddress
                Do 'цикл поиска, т.к. одно и то же значение может встречаться много раз
                    Set iFoundRng = YourRange.FindNext(iFoundRng) 'продолжаем поиск на том же листе
iFoundRng.Offset(, 1).Resize(, k).Value = arrZam
                    'Debug.Print iFoundRng.Address
                Loop While iFoundRng.Address <> firstAddress
            End If


End If
End Sub