Всем привет. При запуске макроса процесс зависает, после чего помогает только перезапуск программы. Код макроса ниже, документ по ссылке. Задача макроса - почистить текст от тегов <b>, </b>, <i>, </i>, любых вариаций [Spoiler] и [/spoiler], а также убрать лишние пробелы и разрывы между строками.
Код
Sub RemoveCarriage()
Dim Rng As Range
Dim WorkRng As Range
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
For Each Rng In WorkRng
Rng.Value = Replace(Rng.Value, Chr(10), "<p>")
Next
For Each cell In WorkRng
Cells.Replace What:="<*b*>", Replacement:="<p>", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Next
For Each cell In WorkRng
Cells.Replace What:="[*spoiler*]", Replacement:="<p>", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Next
For Each cell In WorkRng
Cells.Replace What:="[*i*]", Replacement:="<p>", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Next
For Each Rng In WorkRng
Rng.Value = Application.WorksheetFunction.Trim(Rng.Value)
Next
End Sub
Опыта пока немного, поэтому понимаю, что структура может быть кривой( На небольших количествах строк (10-20) процесс не зависает, но при запуске на все диапазоне виснет намертво. Помогите, пожалуйста.
Спасибо.
Изменено: exellion - 29.11.2019 17:07:13(добавил ссылку на приме)
Если про ошибку, то зачем по каждой ячейке искать если можно по диапазону разом
Код
Dim WorkRng As Range
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
For Each Rng In WorkRng
Rng.Value = Replace(Rng.Value, Chr(10), "<p>")
Next
With WorkRng
.Replace What:="<*b*>", Replacement:="<p>", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
.Replace What:="[*spoiler*]", Replacement:="<p>", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
.Replace What:="[*i*]", Replacement:="<p>", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
End With
For Each Rng In WorkRng
Rng.Value = Application.WorksheetFunction.Trim(Rng.Value)
Next
End Sub
Если по вопросу что делаем, то Множественная замена в большом диапазоне.
... и такие там другие модификации к модификациям ...
Код
Sub Re_Move_Carrie_Age()
Dim i%, xTitleId$, rplc, rplcmnt, workRng
xTitleId = "Title"
rplc = Array(Chr(10), "<*b*>", "[*spoiler*]", "[*i*]")
rplcmnt = Array("<p>", "<p>", "<p>", "<p>")
On Error Resume Next
workRng = Application.InputBox("Range", xTitleId, Selection.Address, Type:=8).Address
If workRng = Empty Then Exit Sub
On Error GoTo 0
With Range(workRng)
For i = 0 To UBound(rplc)
.Replace What:=rplc(i), Replacement:=rplcmnt(i), LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
Next
.Value = Application.Trim(.Value)
.Value = Application.Clean(.Value) ' ???
End With
End Sub
ой там ... :x ... в данном случае тоже ... автор всё равно и так будет рыться в коде, пусть у него будет меньше того рытья, пусть всё "в одном месте" будет а и попрактикует в выборе элементов из переменных массива ... но можно это и поменять, если это чья-то воля: