VBA Slow и не работает с более длинными наборами данных

Проблема в том, что вы используете коллекцию Characters. Если вы хотите покрасить различные слова, найденные, отлично, но сделайте это после того, как вы будете манипулировать всеми строковыми значениями.

Боковое примечание : Повторное использование ActiveSheet меня пугает. Установите это в переменную в начале подпрограммы и используйте вместо нее переменную.

Dim Sheet as Worksheet
Set Sheet = ActiveSheet
.
Sheet.Range(...
.
Set Sheet = nothing

Посмотрите на чтение / запись данных в вариант вместо диапазона. (по крайней мере, для обработки текста) Вот пример загрузки Range в вариант:

Dim vNoiseWords as Variant
vNoiseWords = Sheet.Range("B2", Sheet.Range("B2").End(xlDown)).Value2

Запись просто противоположна (но мне обычно приходится транспонировать массив).

Затем вы можете пройти через массив вариантов и идентифицировать текст, который должен быть окрашен в ячейку.

Свернуть любые и все взаимодействия с листом

... поэтому ограничьте любую строку, которая начинается с ActiveSheet., Cell., Range. и обрабатывает ее только в том случае, если это необходимо.

Даже Cell = UCase(Cell) является огромная трата времени.

. Вам гораздо лучше делать

Value = UCase(Cell.Value2)
If Value <> Cell.Value2 then Cell.Value2 = Value

Обновить

FYI. медленные части вашего кода, добавив временные метки между разделами кода. Вот простая процедура, которую я использую для отслеживания временных интервалов и отображения результатов в непосредственном окне.

Public Sub TimeStamp(Optional Prompt As String, Optional StartTimer As Boolean)
Static s_fTimer As Single, s_fIntervalTimer As Single
Dim fCurrTime As Single
    fCurrTime = Timer
    If StartTimer Then
        s_fTimer = fCurrTime
        s_fIntervalTimer = fCurrTime
    End If
    If Prompt <> vbNullString Then Prompt = " - " & Prompt
    Debug.Print Format((fCurrTime - s_fTimer), "0.000s") & Format((fCurrTime - s_fIntervalTimer), "(0.000s)") & Prompt
    s_fIntervalTimer = fCurrTime
End Sub

При первом вызове (или в любое время, когда вы хотите сбросить счетчик общего времени ), вы должны установить StartTimer = True следующим образом:

TimeStamp "Start of Program", True

После этого просто вызовите подпрограмму с дополнительным приглашением для отслеживания разделов кода:

TimeStamp "After Smart Quote Loop"

TimeStamp "The End"

Затем просто посмотрите на промежутки времени, найдите самые большие и уничтожьте их, если не считаете их разумными. Вы обнаружите, что каждое взаимодействие с UI / ячейками - это задержка, но обработка данных в фоновом режиме занимает очень мало времени.

Чтобы ускорить вычисление, когда вы изменяете значения в электронной таблице, вам нужно сначала отключить обновления экрана и повторно использовать после завершения обработки:

Отключение обновлений:

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

Повторное обновление обновлений:

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

Работа с коллекцией Characters довольно медленная, поэтому вы можете столкнуться с некоторым уровнем плохой производительности.

Однако есть вероятность, что вы можете сэкономить время.

Например:

For j = 1 To Len(s)
    cell.Characters(j, 1).Text = Replace(cell.Characters(j, 1).Text, Chr(147), """")
    cell.Characters(j, 1).Text = Replace(cell.Characters(j, 1).Text, Chr(148), """")

Вам не нужно использовать коллекцию символов здесь, поскольку вы просто очистили весь цвет шрифта, нет необходимости использовать подход Characters или просто заменить с помощью .Value

EDIT: возможно, стоит установить флаг внутри чтобы отслеживать, было ли применено любое форматирование символьного уровня, поэтому вы можете избежать любого ненужного использования .Characters и полагаться вместо этого на .Value

. Вы можете удалите это из цикла:

 cell.Interior.Color = vbWhite
 cell.Characters.Font.Color = vbBlack

и замените на

KeywordSearch.Interior.Color = vbWhite
KeywordSearch.Font.Color = vbBlack

перед циклом

Этот

If word = "and" Or word = "not" Or word = "or" Then
    For j = 1 To Len(word)
        cell.Characters(offset + j - 1, 1).Text = UCase(Mid(word, j, 1))
    Next
End If

может быть быстрее:

If word = "and" Or word = "not" Or word = "or" Then
    cell.Characters(offset, len(word)).Text = UCase(word)
End If