Замена слов определенного цвета в ячейках

[linguist]

Изначально не известно, сколько ячеек будет заполнено. Может быть так, что заменить пробелы нужно будет в одной ячейке, а может быть так, что в 500, но всегда в рамка одного столбца.

[IgorGO]

по-очереди обратится к конкретной ячейке конкретного столбца

(ко всем нужным ячейкам)

[linguist]

Экспериментальным путем я выяснил, что

Sub Заменить_пробелы_в_формулах()

        With Range("A1")
            For i = 1 To .Characters.Count
               With .Characters(Start:=i, Length:=1)
                   If (.Font.Color = 255 Or .Font.Color = 32768) And .Text = " " Then .Text = "_"
               End With
            Next
        End With
        
End Sub

Не работает, если в ячейке больше 255 символов. Это плохо, потому как символов может быть гораздо больше. Можно как-то обойти это ограничение?

[Hugo121]

А если заменить .Characters.Count на Len(.value)?

[linguist]

Len(.Value) не помогло. Меняет только если 255 или меньше символов в ячейке.

[linguist]

Может как-то тип ячейки влияет?

[Serge_Bliznykov]

да, когда символов больше 255 тип ячейки меняется, становится не текстовый, а (по всей видимости Memo) и свойство .Text становится read-only (точнее, в него записывать изменения можно, но это никак не влияет на содержимое).
Как с этим бороться не знаю!

ну, если Вам деваться некуда и нельзя текст разбить по 255 символов.
попробуйте такой макрос:

Sub Заменить_пробелы_в_формулах()
        Dim S As String, L As Long
        S = Range("A1").Text
        With Range("A1")
            L = .Characters.Count
            For i = 1 To .Characters.Count
               With .Characters(Start:=i, Length:=1)
                   If (.Font.Color = 255 Or .Font.Color = 32768) And .Text = " " Then
                     '.Text = "_"
                     S = Left(S, i - 1) & "_" & Right(S, L - i)
                   End If
               End With
            Next
        End With
          
        Range("A1").Copy Range("B1")
        Range("B1").Value = S
        For i = 1 To Range("A1").Characters.Count
               Range("B1").Characters(Start:=i, Length:=1).Font.Color = Range("A1").Characters(Start:=i, Length:=1).Font.Color
        Next
        
End Sub

Только он копирует (с заменой) содержимое из ячейки A1 в ячейку B1
Работает крайне медленно и печально!

[linguist]

Serge_Bliznykov, Спасибо.
Такой код действительно поможет.
Для моей задачи я буду делать так: по вашему коду копировать с заменой пробелов в другую ячейку, потом макросом опять копировать из новой ячейки в старую с заменой и удалением данных из новой ячейки. Это, конечно, будет долго, но для выполнения моей задачи подойдет и такой способ. Все быстрее, чем вручную.

[Serge_Bliznykov]

пожалуйста.

потом макросом опять копировать из новой ячейки в старую с заменой и удалением данных из новой ячейки.

это несложно и можно дописать в конце данного макроса.

для выполнения моей задачи подойдет и такой способ. Все быстрее, чем вручную.

пожалуйста.
как вариант, можно (легко) проверить тип ячейки и, если он IsText - то выполнять предыдущий код (он намного проще и эффективней), а если не текст - тогда уж запускать эту нудятину, что я предложил.
Кроме того, я не теряю надежды, что в теме появится кто-то из профессионалов (а тут на форуме такие Гуру есть) и перепишет мой код так, чтобы он работал быстро и хорошо.

[IgorGO]

скопируйте все в программный модуль

Type SameChars
  b As Integer ' start pos.
  l As Integer ' length
  c As Long    ' color
  p As String  ' blank pos.
End Type


Sub Replace_(cl As Range)
  Const c1& = 255, c2& = 5287936
  Dim i%, j%, p%, n%, dAr() As SameChars
  ReDim dAr(0 To 100) As SameChars
  For i = 1 To cl.Characters.Count
    If dAr(n).c <> cl.Characters(i, 1).Font.Color Then
      dAr(n).l = i - dAr(n).b: n = n + 1: dAr(n).b = i: dAr(n).c = cl.Characters(i, 1).Font.Color
      If n = UBound(dAr) Then ReDim Preserve dAr(0 To UBound(dAr) * 2)
    End If
    If cl.Characters(i, 1).Text = " " Then
      If i > 1 And i < cl.Characters.Count Then
        If cl.Characters(i - 1, 1).Font.Color = dAr(n).c _
          And cl.Characters(i + 1, 1).Font.Color = dAr(n).c _
          And (dAr(n).c = c1 Or dAr(n).c = c2) Then
          dAr(n).p = dAr(n).p & " " & i
        End If
      End If
    End If
  Next
  dAr(n).l = i - dAr(n).b
  For i = 1 To n
    If dAr(i).c <> 0 And dAr(i).p <> "" Then
      For j = 1 To UBound(Split(dAr(i).p))
        p = Val(Split(dAr(i).p)(j))
        cl = Left(cl, p - 1) & "_" & Right(cl, Len(cl) - p)
      Next
    End If
  Next
  For i = 1 To n
    If dAr(i).c <> 0 Then cl.Characters(dAr(i).b, dAr(i).l).Font.Color = dAr(i).c
  Next
End Sub


Sub RunThis1() ' replace in A1
  Dim tm As Single
  tm = Timer
  Replace_ Cells(1, 1)
  MsgBox Timer - tm
End Sub


Sub RunThis2() ' replace in B6:B7
  Dim tm As Single, rg As Range
  tm = Timer
  For Each rg In Range("B6:B7")
    Replace_ rg
  Next
  MsgBox Timer - tm
End Sub

все работает удручающе медленного, но, видимо, это будет быстрее, чем править руками

Replace_ - собственно сама процедура замены
RunThis1, RunThis2 - примеры ее использования для одной ячейки или для диапазона ячеек