[blackeangel]

Решение найдено.

Код:

Sub raspil()
Application.ScreenUpdating = False
i = 2
sWhatFind = "Маршрут"
Cells.Find(What:=sWhatFind, After:=ActiveCell, SearchOrder:=xlByColumns).Activate
ncolumn = ActiveCell.Column
Do While Cells(i, ncolumn).Value <> Empty
If Cells(i, ncolumn).Value Like "*3000*" Then
Cells(i, ncolumn + 1).Value = "3000"
Else
If Cells(i, ncolumn).Value Like "*3100*" Then
Cells(i, ncolumn + 1).Value = "3100"
Else
If Cells(i, ncolumn).Value Like "*3200*" Then
Cells(i, ncolumn + 1).Value = "3200"
Else
If Cells(i, ncolumn).Value Like "*3300*" Then
Cells(i, ncolumn + 1).Value = "3300"
Else
If Cells(i, ncolumn).Value Like "*3400*" Then
Cells(i, ncolumn + 1).Value = "3400"
Else
If Cells(i, ncolumn).Value Like "*3600*" Then
Cells(i, ncolumn + 1).Value = "3600"
Else
If Cells(i, ncolumn).Value Like "*3800*" Then
Cells(i, ncolumn + 1).Value = "3800"
Else
If Cells(i, ncolumn).Value Like "*3801*" Then
Cells(i, ncolumn + 1).Value = "3801"
Else
If Cells(i, ncolumn).Value Like "*2400*" Then
Cells(i, ncolumn + 1).Value = "2400"
End If
End If
End If
End If
End If
End If
End If
End If
End If
i = i + 1
Loop
Application.ScreenUpdating = True
End Sub