Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Множественная замена в большом диапазоне., зависает Excel при выполнении макроса
 
#1
29.11.2019 17:04:13
Всем привет. При запуске макроса процесс зависает, после чего помогает только перезапуск программы.
Код макроса ниже, документ по ссылке. Задача макроса - почистить текст от тегов <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 (добавил ссылку на приме)
 
 
 
#2
29.11.2019 17:05:25
На общий вопрос дают общий ответ...
Задача какая? Это и нужно  сообщить заголовком темы.
 
 
 
#3
29.11.2019 17:18:46
Описал задачу в первом абзаце сообщения, ссылка на файл там же. Если нужно что-то уточнить, буду рад помочь.
 
 
 
#4
29.11.2019 17:20:20
Уточняю: по названию темы посетитель должен понять, стоит ли ему в тему заглядывать и терять время.
 
 
 
#5
29.11.2019 17:27:33
Понял, а как изменить шапку? В редактировании вижу только возможность редактировать сообщение.
 
 
 
#6
29.11.2019 17:57:22
И не сможете.  Предложите.  Модераторы  заменят
 
 
 
#7
29.11.2019 18:08:22
Если про ошибку, то зачем по каждой ячейке искать если можно по диапазону разом
Код
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


Если по вопросу что делаем, то Множественная замена в большом диапазоне.
По вопросам из тем форума, личку не читаю.
 
 
 
#8
30.11.2019 02:51:54
... и такие там другие модификации к модификациям ...
Код
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
 
 
 
#9
30.11.2019 08:41:29
ocet p, я понимаю зачем второй массив в общем, но не в данном случае

Код
 With Range(workRng)
        For each strWhat  in rplc
            .Replace What:=strWhat, Replacement:="<p>", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
        Next
По вопросам из тем форума, личку не читаю.
 
 
 
#10
30.11.2019 16:13:33
ой там ... :x ... в данном случае тоже ... автор всё равно и так будет рыться в коде, пусть у него будет меньше того рытья, пусть всё "в одном месте" будет а и попрактикует в выборе элементов из переменных массива ... но можно это и поменять, если это чья-то воля:
Код
    rplc = Array(Chr(10), "<*b*>", "[*spoiler*]", "[*i*]")
    rplcmnt = "<p>" ' Array("<p>", "<p>", "<p>", "<p>")
    '...
        .Replace What:=rplc(i), Replacement:=rplcmnt
    '...
... но это выглядит так как-то не "симметрично" ... : (
 
 
 
Страницы: 1
Наверх