Посимвольная смена формата текста - Мир MS Excel

Регистрация

Напомнить пароль

= Мир MS Excel/Посимвольная смена формата текста - Мир MS Excel

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Посимвольная смена формата текста (Макросы/Sub)

Посимвольная смена формата текста

Дата: Среда, 15.03.2017, 13:53 | Сообщение № 1

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 131

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

Добрый день, специалисты по экселю.
Помогите решить проблему.

У меня на листе располагается ячейка E9 с текстом.
Изначально текст в ячейке E9 - белого цвета - то есть он не виден.

Подскажите, как макросом заставить - постепенно, с задержкой в полсекунды в ячейке E9 - слева направо - менять цвет символов этого текста с белого на черный ?

(Таким образом - сперва появляется буква "п", затем "о", затем "н", затем "е", затем "д" и так далее - пока весь текст не станет видимым.)

К сообщению приложен файл: 1273426.xls (30.0 Kb)

Ответить

Дата: Среда, 15.03.2017, 14:33 | Сообщение № 2

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 167

Репутация: 43 ±

Замечаний: 0% ±

Excel 2007, 2010

cerber412, а Вы понимаете что пока макрос будет рисовать буквы Excel будет занят и нельзя будет в нем работать?
~~Посимвольно задавать параметры шрифта на сколько я знаю нельзя~~ Можно

Сообщение отредактировал devilkurs - Среда, 15.03.2017, 14:37

Ответить

Дата: Среда, 15.03.2017, 14:38 | Сообщение № 3

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 131

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

devilkurs, понимаю.
Но готов пожертвовать этим.

Ответить

Дата: Среда, 15.03.2017, 14:48 | Сообщение № 4

Группа: Заблокированные

Ранг: Участник клуба

Сообщений: 3442

Репутация: 929 ±

Замечаний: 20% ±

2010, 2013, 2016 RUS / ENG

Можно и посимвольно [vba]

Код

Sub Posimv1()
   l = Len([a1])
   For i = 1 To l
    Cells(1, 1).Characters(Start:=i, Length:=1).Font.Color = 122224
   Application.Wait Time:=Now + TimeSerial(0, 0, 1)
   Next
End Sub

[/vba]

К сообщению приложен файл: 9745350.xlsm (13.8 Kb)

Ответить

Дата: Среда, 15.03.2017, 14:51 | Сообщение № 5

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 131

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

buchlotnik, большое спасибо.
Именно это и требовалось.

Ответить

Дата: Среда, 15.03.2017, 14:54 | Сообщение № 6

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 167

Репутация: 43 ±

Замечаний: 0% ±

Excel 2007, 2010

Не поспеешь за вами hands

hands

[vba]

Код

Sub devilkurs()
Dim i%
With Range("E9")
    .Font.Color = vbWhite
    For i = 1 To Len(.Value)
        .Characters(Start:=1, Length:=i).Font.Color = vbBlack
        Application.Wait Time:=Now + TimeSerial(0, 0, 1)
    Next
End With
End Sub

[/vba]

Ответить

Дата: Среда, 15.03.2017, 15:02 | Сообщение № 7

Группа: Проверенные

Ранг: Ветеран

Сообщений: 712

Репутация: 156 ±

Замечаний: 0% ±

Excel 2003

[vba]

Код

Option Explicit

Declare Sub Sleep Lib "kernel32" (ByVal dwmilliseconds As Long)
Sub iFont()
Dim i As Integer
Range("E7").Copy Range("E9")
Range("E9").Font.ColorIndex = 2
Range("E9").Activate
  For i = 1 To Len(Range("E9"))
   With ActiveCell.Characters(i, 1).Font
     .ColorIndex = 1
     Sleep 500
   End With
  Next
End Sub

[/vba]

Ответить

Дата: Среда, 15.03.2017, 15:03 | Сообщение № 8

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 237

Репутация: 59 ±

Замечаний: 0% ±

Excel 2010

Чуть посложнее, зато можно задержку меньше секунды задавать.
[vba]

Код

Sub chColorTxt()
  Dim Sec As Double, lR As Long, R As Long

  lR = Len(ActiveCell.Value)
  Sec = Len(ActiveCell.Value) / 2

  With ActiveCell.Font
    .ColorIndex = 2

    dBeg = Date
    tBeg = (Date - dBeg) * 86400 + Timer
    tEnd = tBeg + Sec
    Do
        t = (Date - dBeg) * 86400 + Timer
        R = 1 + (lR - 1) * (t - tBeg) / Sec
        ActiveCell.Characters(Start:=R, Length:=1).Font.ColorIndex = xlAutomatic
'        DoEvents
    Loop While ((Date - dBeg) * 86400 + Timer) < tEnd
    ActiveCell.Font.ColorIndex = xlAutomatic
  End With
End Sub

[/vba]

А если активировать DoEvents, то можно прервать действием пользователя в любой момент. Только тогда слово недокрашенным останется.

Ответить

Дата: Среда, 15.03.2017, 16:23 | Сообщение № 9

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 131

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

Perfect2You, а ваш код - вообще как работает?

Я выделяю ячейку Е9, нажимаю на кнопку - и текст моментально перекрашивается.
Я имел ввиду постепенное перекрашивание.

Ответить

Дата: Среда, 15.03.2017, 17:20 | Сообщение № 10

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 237

Репутация: 59 ±

Замечаний: 0% ±

Excel 2010

Заинтересовались? Хорошо.
У меня перекрашивается постепенно. Можно поиграть установками Sec. Если длина строки пополам - примерно полсекунды на букву. Если задать число, например, 3. Будет на все слово затрачено 3 секунды (для длинного слова каждая буква быстрее будет проявляться, для короткого - дольше).

Чтобы ответить на Ваш вопрос, нужен файл, в котором Вы, выделив E9 нажимаете кнопку. Может кнопке там по ошибке вовсе не мой макрос назначен?

Если, правда, в моем коде глюк, готов смотреть и править.

Сейчас проверил. Не работает, если в ячейке результат вычисления формулы, а не значение. Но тогда никакой, скорее всего, из предложенных, не взял бы такую планку.

С уважением.

Сообщение отредактировал Perfect2You - Среда, 15.03.2017, 17:32

Ответить

Дата: Среда, 15.03.2017, 17:59 | Сообщение № 11

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 237

Репутация: 59 ±

Замечаний: 0% ±

Excel 2010

Точно! У Вас там формула стояла!
Конкретно под Ваши нужды. Даже если будет формула массива - в конце вернет и оставит формулой массива:
[vba]

Код

Sub chColorTxt()
Dim Sec As Double, lR As Long, R As Long, strIn As String, strInM As String

    Set cc = ActiveCell
    If ActiveCell.HasArray Then
        strInM = ActiveCell.FormulaArray
    Else
        strIn = ActiveCell.Formula
    End If
    ActiveCell.Value = ActiveCell.Value
    lR = Len(ActiveCell.Value)
'    Sec = Len(ActiveCell.Value) / 2
    Sec = 5

    ActiveCell.Font.ColorIndex = 2
    dBeg = Date
    tBeg = (Date - dBeg) * 86400 + Timer
    tEnd = tBeg + Sec
    Do
        t = (Date - dBeg) * 86400 + Timer
        R = 1 + (lR - 1) * (t - tBeg) / Sec
        ActiveCell.Characters(Start:=R, Length:=1).Font.ColorIndex = xlAutomatic
        DoEvents
    Loop While ((Date - dBeg) * 86400 + Timer) < tEnd
    ActiveCell.Font.ColorIndex = xlAutomatic
    If Len(strInM) Then
        ActiveCell.FormulaArray = strInM
    Else
        ActiveCell.Formula = strIn
    End If

End Sub

[/vba]

Ответить

Дата: Среда, 15.03.2017, 18:17 | Сообщение № 12

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 131

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

Perfect2You, ого ... мощный код !
Большое спасибо.

Ответить

Дата: Среда, 15.03.2017, 18:39 | Сообщение № 13

Группа: Проверенные

Ранг: Ветеран

Сообщений: 712

Репутация: 156 ±

Замечаний: 0% ±

Excel 2003

А мой код не подошел?

Ответить

Дата: Среда, 15.03.2017, 19:13 | Сообщение № 14

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 131

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

Kuzmich, а ваш код я не смог оценить - поскольку у меня 64 разрядный windows7
Но я уверен, что код - тоже хороший.

Ответить

Дата: Среда, 15.03.2017, 19:38 | Сообщение № 15

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 237

Репутация: 59 ±

Замечаний: 0% ±

Excel 2010

Чтобы оценить код Kuzmich, замените:
[vba]

Код

Declare Sub Sleep Lib "kernel32" (ByVal dwmilliseconds As Long)

[/vba]
на
[vba]

Код

Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwmilliseconds As LongPtr)

[/vba]
Только этот код, по-моему, формулу в E9 не восстановит.

Сообщение отредактировал Perfect2You - Среда, 15.03.2017, 19:40

Ответить

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Посимвольная смена формата текста (Макросы/Sub)

Страница 1 из 1
1

© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!