Попробуйте такой вариант:
Sub Main()
Dim sh As Worksheet: Set sh = ActiveSheet
Dim cell As Range, ra As Range: Application.ScreenUpdating = False
Set ra = sh.Range(sh.[b7], sh.Range("b" & sh.Rows.Count).End(xlUp))
For Each cell In ra.Cells
newtxt = УдалитьТекстМеждуСловами(cell, "грузов", "расстояние")
newtxt = УдалитьТекстМеждуСловами(newtxt, "км", "груза 1")
newtxt = Application.WorksheetFunction.Trim(Replace(newtxt, "груза 1", ""))
If newtxt <> cell.Text Then cell = newtxt
Next cell
End Sub
Function УдалитьТекстМеждуСловами(ByVal txt As String, ByVal txt1 As String, _
ByVal txt2 As String) As String
УдалитьТекстМеждуСловами = txt
pos1 = InStr(1, txt, txt1, vbTextCompare): If pos1 = 0 Then Exit Function
pos1 = pos1 + Len(txt1)
pos2 = InStr(pos1, txt, txt2, vbTextCompare): If pos2 = 0 Then Exit Function
УдалитьТекстМеждуСловами = Left(txt, pos1) & Mid(txt, pos2)
End Function
> Или я ..., или это недавно было, но только про курсив?
Было...
Пора нам уже привыкнуть к причудам форумчан :)
