Dim pobjCell As Range Dim plCharCounter As Long Dim psCellText As String Dim i As Long
i = 0
For Each pobjCell In Selection psCellText = pobjCell.Text Do While InStr(psCellText, vbCr) > 0 psCellText = Replace$(psCellText, vbCr, " ") Loop
Do While InStr(psCellText, vbLf) > 0 psCellText = Replace$(psCellText, vbLf, " ") Loop
Do While InStr(psCellText, vbTab) > 0 psCellText = Replace$(psCellText, vbTab, " ") Loop
Do While InStr(psCellText, """") > 0 psCellText = Replace$(psCellText, """", " ") Loop
Do While InStr(psCellText, "'") > 0 psCellText = Replace$(psCellText, "'", " ") Loop
Do While InStr(psCellText, "«") > 0 psCellText = Replace$(psCellText, "«", " ") Loop
Do While InStr(psCellText, "»") > 0 psCellText = Replace$(psCellText, "»", " ") Loop
Do While InStr(psCellText, ";") > 0 psCellText = Replace$(psCellText, ";", " ") Loop
Do While InStr(psCellText, "--") > 0 psCellText = Replace$(psCellText, "--", "-") Loop
Do While InStr(psCellText, "\") > 0 psCellText = Replace$(psCellText, "\", " ") Loop
If psCellText = "(null)" Then psCellText = "" End If
psCellText = Trim(psCellText)
If (pobjCell.Value <> psCellText) Then pobjCell.Font.ColorIndex = 3 i = i + 1 End If
pobjCell.Value = psCellText Next
MsgBox (Str(i) + " items replaced.")
End Sub
[/vba]
Появилась необходимость предварительного преобразования форматов выбранных ячеек в текст без искажения содержимого (как происходит после перевода даты в текстовый формат). Не программист, надеюсь на понимание. Спасибо заранее!
Доброго времени суток!
Есть скрипт следующего вида: [vba]
Код
Sub RemoveCrLfs()
Dim pobjCell As Range Dim plCharCounter As Long Dim psCellText As String Dim i As Long
i = 0
For Each pobjCell In Selection psCellText = pobjCell.Text Do While InStr(psCellText, vbCr) > 0 psCellText = Replace$(psCellText, vbCr, " ") Loop
Do While InStr(psCellText, vbLf) > 0 psCellText = Replace$(psCellText, vbLf, " ") Loop
Do While InStr(psCellText, vbTab) > 0 psCellText = Replace$(psCellText, vbTab, " ") Loop
Do While InStr(psCellText, """") > 0 psCellText = Replace$(psCellText, """", " ") Loop
Do While InStr(psCellText, "'") > 0 psCellText = Replace$(psCellText, "'", " ") Loop
Do While InStr(psCellText, "«") > 0 psCellText = Replace$(psCellText, "«", " ") Loop
Do While InStr(psCellText, "»") > 0 psCellText = Replace$(psCellText, "»", " ") Loop
Do While InStr(psCellText, ";") > 0 psCellText = Replace$(psCellText, ";", " ") Loop
Do While InStr(psCellText, "--") > 0 psCellText = Replace$(psCellText, "--", "-") Loop
Do While InStr(psCellText, "\") > 0 psCellText = Replace$(psCellText, "\", " ") Loop
If psCellText = "(null)" Then psCellText = "" End If
psCellText = Trim(psCellText)
If (pobjCell.Value <> psCellText) Then pobjCell.Font.ColorIndex = 3 i = i + 1 End If
pobjCell.Value = psCellText Next
MsgBox (Str(i) + " items replaced.")
End Sub
[/vba]
Появилась необходимость предварительного преобразования форматов выбранных ячеек в текст без искажения содержимого (как происходит после перевода даты в текстовый формат). Не программист, надеюсь на понимание. Спасибо заранее!MitaMax
С уважением, Максим М.
Сообщение отредактировал MitaMax - Среда, 14.05.2014, 15:28
Ну, вообще-то нафиг не нужны циклы с реплэйсами, т.к. функция Replace по умолчанию заменяет сразу все найденные в стринге символы на заданные А вот то, что после замен символов на пробелы эти пробелы символы могут быть не только в начале или конце результирующего стринга, но и между его буквами, Вы не учли. А простой Trim убирает только лидирующие и финишные пробелы. Вам же нужен аналог функции листа СЖПРОБЕЛЫ - Application.WorksheetFunction.Trim (эту запись чаще всего можно сократить до Application.Trim , хотя иногда почему-то не прокатывает). Ну и про существование неразвывных пробелов - Chr(160) - Вы забыли, а они частенько портят кровь. Что Вы хотели выловить в строчке [vba]
Код
If psCellText = "(null)" Then …
[/vba]я не понял. Может быть у Вас такая фигня на листе откуда-то есть. Поэтому тупо оставил. А [vba]
Код
If (pobjCell.Value <> psCellText) Then
[/vba] лучше заменить на [vba]
Код
If Not pobjCell.Text Like psCellText Then
[/vba]тогда не будет вылетать Type Mismatch при обнаружении на листе формул, возвращающих ошибки, которые в ячейках обозначаются, например, как #ЗНАЧ! , а на самом деле - это цифровые коды ошибок. Ну и ускорить обработку не плохо бы отключением обновления экрана и автоматического пересчёта ячеек. Т.е. примерно так Вашу процедуру можно урезать и подпилить:
[vba]
Код
Sub RemoveCrLfs() Dim pobjCell As Range Dim psCellText As String Dim i As Long Application.ScreenUpdating = False: Application.Calculation = xlManual For Each pobjCell In Selection psCellText = pobjCell.Text psCellText = Replace$(psCellText, vbCr, " ") psCellText = Replace$(psCellText, vbLf, " ") psCellText = Replace$(psCellText, vbTab, " ") psCellText = Replace$(psCellText, """", " ") psCellText = Replace$(psCellText, "'", " ") psCellText = Replace$(psCellText, "«", " ") psCellText = Replace$(psCellText, "»", " ") psCellText = Replace$(psCellText, ";", " ") psCellText = Replace$(psCellText, "--", "-") psCellText = Replace$(psCellText, "\", " ") psCellText = Replace$(psCellText, Chr(160), " ") ' Chr(160) - неразрывный пробел
If psCellText = "(null)" Then psCellText = "" ' ???
If Not pobjCell.Text Like psCellText Then pobjCell.Font.ColorIndex = 3 i = i + 1 End If pobjCell.Value = psCellText Next Application.ScreenUpdating = True: Application.Calculation = xlAutomatic MsgBox (i & " items replaced.") End Sub
[/vba]
Конечно, используя регулярные выражения, можно было бы и ещё сократить, но я их навскидку не помню, а лазить по своей "копилке" просто лень
Ну, вообще-то нафиг не нужны циклы с реплэйсами, т.к. функция Replace по умолчанию заменяет сразу все найденные в стринге символы на заданные А вот то, что после замен символов на пробелы эти пробелы символы могут быть не только в начале или конце результирующего стринга, но и между его буквами, Вы не учли. А простой Trim убирает только лидирующие и финишные пробелы. Вам же нужен аналог функции листа СЖПРОБЕЛЫ - Application.WorksheetFunction.Trim (эту запись чаще всего можно сократить до Application.Trim , хотя иногда почему-то не прокатывает). Ну и про существование неразвывных пробелов - Chr(160) - Вы забыли, а они частенько портят кровь. Что Вы хотели выловить в строчке [vba]
Код
If psCellText = "(null)" Then …
[/vba]я не понял. Может быть у Вас такая фигня на листе откуда-то есть. Поэтому тупо оставил. А [vba]
Код
If (pobjCell.Value <> psCellText) Then
[/vba] лучше заменить на [vba]
Код
If Not pobjCell.Text Like psCellText Then
[/vba]тогда не будет вылетать Type Mismatch при обнаружении на листе формул, возвращающих ошибки, которые в ячейках обозначаются, например, как #ЗНАЧ! , а на самом деле - это цифровые коды ошибок. Ну и ускорить обработку не плохо бы отключением обновления экрана и автоматического пересчёта ячеек. Т.е. примерно так Вашу процедуру можно урезать и подпилить:
[vba]
Код
Sub RemoveCrLfs() Dim pobjCell As Range Dim psCellText As String Dim i As Long Application.ScreenUpdating = False: Application.Calculation = xlManual For Each pobjCell In Selection psCellText = pobjCell.Text psCellText = Replace$(psCellText, vbCr, " ") psCellText = Replace$(psCellText, vbLf, " ") psCellText = Replace$(psCellText, vbTab, " ") psCellText = Replace$(psCellText, """", " ") psCellText = Replace$(psCellText, "'", " ") psCellText = Replace$(psCellText, "«", " ") psCellText = Replace$(psCellText, "»", " ") psCellText = Replace$(psCellText, ";", " ") psCellText = Replace$(psCellText, "--", "-") psCellText = Replace$(psCellText, "\", " ") psCellText = Replace$(psCellText, Chr(160), " ") ' Chr(160) - неразрывный пробел
If psCellText = "(null)" Then psCellText = "" ' ???
If Not pobjCell.Text Like psCellText Then pobjCell.Font.ColorIndex = 3 i = i + 1 End If pobjCell.Value = psCellText Next Application.ScreenUpdating = True: Application.Calculation = xlAutomatic MsgBox (i & " items replaced.") End Sub
[/vba]
Конечно, используя регулярные выражения, можно было бы и ещё сократить, но я их навскидку не помню, а лазить по своей "копилке" просто леньAlex_ST
С уважением, Алексей MS Excel 2003 - the best!!!
Сообщение отредактировал Alex_ST - Четверг, 15.05.2014, 14:03
Если есть желание, загляните в ЭТОТ топик. Там при доработке макроса Trim_By_Formula народ приводил примеры использования регулярных выражений. Намного короче получается
Если есть желание, загляните в ЭТОТ топик. Там при доработке макроса Trim_By_Formula народ приводил примеры использования регулярных выражений. Намного короче получаетсяAlex_ST
Возникла следующая задача - попросили наваять скрипт для выверки длины текстового поля в ячейке (8 символов),дабы в выбранном столбце (или диапазоне) строки,неуд. этому условию,подсвечивались цветом. Мой вариант
Sub CountSumbol() Dim pobjCell As Range Dim plCharCounter As Long Dim psCellText As String
For Each pobjCell In Selection psCellText = pobjCell.Text If Len(psCellText) <> 8 Then pobjCell.Font.ColorIndex = 13 End If Next End Sub
работать отказывается. Подскажите где косячу. Заранее Спасибо!
Допилил таки скрипт, спасибо Вам за помощь!
Возникла следующая задача - попросили наваять скрипт для выверки длины текстового поля в ячейке (8 символов),дабы в выбранном столбце (или диапазоне) строки,неуд. этому условию,подсвечивались цветом. Мой вариант
Sub CountSumbol() Dim pobjCell As Range Dim plCharCounter As Long Dim psCellText As String
For Each pobjCell In Selection psCellText = pobjCell.Text If Len(psCellText) <> 8 Then pobjCell.Font.ColorIndex = 13 End If Next End Sub
работать отказывается. Подскажите где косячу. Заранее Спасибо!MitaMax
И лучше всё-таки не по всем выделенным ячейкам циклом бегать (а то вдруг кто-нибудь весь лист выберет - ждать замучаетесь), а ограничиться UsedRange [vba]
Код
For Each pobjCell In Intersect(ActiveWindow.RangeSelection, ActiveSheet.UsedRange)
[/vba]А ещё лучше - ещё и видимыми ячейками с константами: [vba]
Код
For Each pobjCell In Intersect(ActiveWindow.RangeSelection.SpecialCells(xlCellTypeVisible), ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants))
[/vba] Только перед началом цикла лучше бы проверить выбранный таким образом диапазон на то, что он не Nothing, а то в ошибку можете вылететь. Ну и ещё как всегда: [vba]
Код
With Application: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual: End With
[/vba]в начале и[vba]
Код
With Application: .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlAutomatic: End With
[/vba]в конце. Тогда точно шустренько будет
И лучше всё-таки не по всем выделенным ячейкам циклом бегать (а то вдруг кто-нибудь весь лист выберет - ждать замучаетесь), а ограничиться UsedRange [vba]
Код
For Each pobjCell In Intersect(ActiveWindow.RangeSelection, ActiveSheet.UsedRange)
[/vba]А ещё лучше - ещё и видимыми ячейками с константами: [vba]
Код
For Each pobjCell In Intersect(ActiveWindow.RangeSelection.SpecialCells(xlCellTypeVisible), ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants))
[/vba] Только перед началом цикла лучше бы проверить выбранный таким образом диапазон на то, что он не Nothing, а то в ошибку можете вылететь. Ну и ещё как всегда: [vba]
Код
With Application: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual: End With
[/vba]в начале и[vba]
Код
With Application: .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlAutomatic: End With
[/vba]в конце. Тогда точно шустренько будетAlex_ST
С уважением, Алексей MS Excel 2003 - the best!!!
Сообщение отредактировал Alex_ST - Вторник, 20.05.2014, 17:04
Алексей, скрипт ожил!Спасибо Вам! сейчас пытаюсь добавить в него проверку на повторяющиеся числовые записи,столкнулся с тем что не знаю как обратиться к предыдущей ячейке вариант [vba]
Код
pobjcell-1
[/vba] компилятор естественно не понимает вопрос : заработает ли ,если добавить ?? [vba]
Код
Dim i As Long .... if CLng(pobjcell.Text[i-1]-CLng(pobjcell.Text[i] = 1 Then pobjCell[i-1].Font.ColorIndex = 5 pobjCell[i].Font.ColorIndex = 5 End If
[/vba]
Алексей, скрипт ожил!Спасибо Вам! сейчас пытаюсь добавить в него проверку на повторяющиеся числовые записи,столкнулся с тем что не знаю как обратиться к предыдущей ячейке вариант [vba]
Код
pobjcell-1
[/vba] компилятор естественно не понимает вопрос : заработает ли ,если добавить ?? [vba]
Код
Dim i As Long .... if CLng(pobjcell.Text[i-1]-CLng(pobjcell.Text[i] = 1 Then pobjCell[i-1].Font.ColorIndex = 5 pobjCell[i].Font.ColorIndex = 5 End If
Для обращения к ячейкам, сдвинутым относительно заданной на +/- сколько нужно столбцов и строк используется свойство Offset:
ЦитатаСправка Excel
Returns a Range object that represents a range that’s offset from the specified range. Read-only.
expression.Offset(RowOffset, ColumnOffset) expression Required. An expression that returns a Range object.
RowOffset Optional Variant. The number of rows (positive, negative, or 0 (zero)) by which the range is to be offset. Positive values are offset downward, and negative values are offset upward. The default value is 0.
ColumnOffset Optional Variant. The number of columns (positive, negative, or 0 (zero)) by which the range is to be offset. Positive values are offset to the right, and negative values are offset to the left. The default value is 0.
Для обращения к ячейкам, сдвинутым относительно заданной на +/- сколько нужно столбцов и строк используется свойство Offset:
ЦитатаСправка Excel
Returns a Range object that represents a range that’s offset from the specified range. Read-only.
expression.Offset(RowOffset, ColumnOffset) expression Required. An expression that returns a Range object.
RowOffset Optional Variant. The number of rows (positive, negative, or 0 (zero)) by which the range is to be offset. Positive values are offset downward, and negative values are offset upward. The default value is 0.
ColumnOffset Optional Variant. The number of columns (positive, negative, or 0 (zero)) by which the range is to be offset. Positive values are offset to the right, and negative values are offset to the left. The default value is 0.
Но, конечно, если Вы хотите обратиться именно к ячейке, которая обрабатывалась в предыдущем цикле, а не просто к сдвинутой, то можно и извратиться: задать ещё и дополнительную переменную, например, PrevCell As Range и при входе в очередной цикл её раскрашивать, а перед перед выходом из цикла устанавливать её равной текущей ячейке-переменной цикла: Set PrevCell = pobjCell
Но, конечно, если Вы хотите обратиться именно к ячейке, которая обрабатывалась в предыдущем цикле, а не просто к сдвинутой, то можно и извратиться: задать ещё и дополнительную переменную, например, PrevCell As Range и при входе в очередной цикл её раскрашивать, а перед перед выходом из цикла устанавливать её равной текущей ячейке-переменной цикла: Set PrevCell = pobjCellAlex_ST
С уважением, Алексей MS Excel 2003 - the best!!!
Сообщение отредактировал Alex_ST - Четверг, 22.05.2014, 13:38
Ввел по Вашему совету переменную PrevCell и добавил для нее строковую PrevCellText соответственно. задаю для нее начальное значение путем обращения к свойству PrevCell.Text выкидывает с ошибкой(комментарий в спойлере)...
[vba]
Код
Sub CountSumbol() Dim pobjCell As Range Dim plCharCounter As Long Dim psCellText, PrevCellText As String Dim PrevCell As Range PrevCell.Text = "1111" With Application: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual: End With For Each pobjCell In Intersect(ActiveWindow.RangeSelection.SpecialCells(xlCellTypeVisible), ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants)) psCellText = pobjCell.Text PrevCellText = PrevCell.Text '!!!ОШИБКА с кодом 91 If Len(psCellText) <> 8 Then pobjCell.Font.ColorIndex = 4 End If If CLng(PrevCellText) - CLng(psCellText) = 1 Then pobjCell.Font.ColorIndex = 5 PrevCell.Font.ColorIndex = 5 End If Set PrevCell = pobjCell Next With Application: .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlAutomatic: End With End Sub
[/vba]
Судя по всему косяк случается когда происходит перекод из строки в число,тк столбец начинается с буквенного заголовка:
Может стоит использовать другую функцию перекода форматов или какой-нибудь хитрый прием?
Ввел по Вашему совету переменную PrevCell и добавил для нее строковую PrevCellText соответственно. задаю для нее начальное значение путем обращения к свойству PrevCell.Text выкидывает с ошибкой(комментарий в спойлере)...
[vba]
Код
Sub CountSumbol() Dim pobjCell As Range Dim plCharCounter As Long Dim psCellText, PrevCellText As String Dim PrevCell As Range PrevCell.Text = "1111" With Application: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual: End With For Each pobjCell In Intersect(ActiveWindow.RangeSelection.SpecialCells(xlCellTypeVisible), ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants)) psCellText = pobjCell.Text PrevCellText = PrevCell.Text '!!!ОШИБКА с кодом 91 If Len(psCellText) <> 8 Then pobjCell.Font.ColorIndex = 4 End If If CLng(PrevCellText) - CLng(psCellText) = 1 Then pobjCell.Font.ColorIndex = 5 PrevCell.Font.ColorIndex = 5 End If Set PrevCell = pobjCell Next With Application: .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlAutomatic: End With End Sub
[/vba]
Судя по всему косяк случается когда происходит перекод из строки в число,тк столбец начинается с буквенного заголовка:
MitaMax, пользуйтесь, пожалуйста, тэгами оформления кода VBA. Абсолютно невозможно читать Ваши посты. ----------------------------- У меня завал на работе. Наспех набросал. Не отлаживал. Проверьте:
[vba]
Код
Sub CountSymbol() Dim rCell As Range, rPrevCell As Range Set rPrevCell = ActiveWindow.RangeSelection(1) With Application: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual: End With For Each rCell In Intersect(ActiveWindow.RangeSelection.SpecialCells(xlCellTypeVisible), ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants)) If Len(CStr(rCell)) <> 8 Then rCell.Font.ColorIndex = 4 If CInt(rPrevCell) - CInt(rCell) = 1 Then rCell.Font.ColorIndex = 5 rPrevCell.Font.ColorIndex = 5 End If Set rPrevCell = rCell Next rCell With Application: .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlAutomatic: End With End Sub
[/vba]
Вполне возможны вылеты на строке [vba]
Код
If CInt(rPrevCell) - CInt(rCell) = 1 Then
[/vba]Надо чуть подумать, как обойти... Нет времени.
MitaMax, пользуйтесь, пожалуйста, тэгами оформления кода VBA. Абсолютно невозможно читать Ваши посты. ----------------------------- У меня завал на работе. Наспех набросал. Не отлаживал. Проверьте:
[vba]
Код
Sub CountSymbol() Dim rCell As Range, rPrevCell As Range Set rPrevCell = ActiveWindow.RangeSelection(1) With Application: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual: End With For Each rCell In Intersect(ActiveWindow.RangeSelection.SpecialCells(xlCellTypeVisible), ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants)) If Len(CStr(rCell)) <> 8 Then rCell.Font.ColorIndex = 4 If CInt(rPrevCell) - CInt(rCell) = 1 Then rCell.Font.ColorIndex = 5 rPrevCell.Font.ColorIndex = 5 End If Set rPrevCell = rCell Next rCell With Application: .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlAutomatic: End With End Sub
[/vba]
Вполне возможны вылеты на строке [vba]
Код
If CInt(rPrevCell) - CInt(rCell) = 1 Then
[/vba]Надо чуть подумать, как обойти... Нет времени.Alex_ST
С уважением, Алексей MS Excel 2003 - the best!!!
Сообщение отредактировал Alex_ST - Четверг, 22.05.2014, 16:39
Добрый день! Кой-чего исправил,подсвечивает,только при условии если не брать заголовок столбца (текстовый)... дабы побороть этот баг, решил добавить еще одну проверку на буквы (нашел массив для украинского языка,но пойдет и мне) добавил в скрипт данный массив [vba]
If InStr(CStr(rCell), CStr(alf)) <> 1 And CLng(rCell) - CLng(rPrevCell) = 1 Then
[/vba] такой механизм у меня не работает,экспериментирую дальше... [p.s.]Извините ,что отвлекаю от работы...
Добрый день! Кой-чего исправил,подсвечивает,только при условии если не брать заголовок столбца (текстовый)... дабы побороть этот баг, решил добавить еще одну проверку на буквы (нашел массив для украинского языка,но пойдет и мне) добавил в скрипт данный массив [vba]
И не мудрено. Кто Вас научил ТАК обращаться с массивами? И что Вы надеялись получить от CStr(alf) ? Если уж хотите что-то сравнивать с набором символов, то используйте оператор Like. Он понимает перечисления и метасимволы. Посмотрите справку. Пригодится где-нибудь. Но только не в этом случае. Тут вполне достаточно перед вычислениями проверять типы переменных любым из доступных методов [vba]
Код
If IsNumeric(rCell) Then … If TypeName(rCell) <> "String" Then … If VarType(rCell) < vbString Then …
[/vba] В общем, Ваш макрос, скорее всего заработает так:
[vba]
Код
Sub CountSymbol() Dim rCell As Range, rPrevCell As Range Set rPrevCell = ActiveWindow.RangeSelection(1) With Application: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual: End With For Each rCell In Intersect(ActiveWindow.RangeSelection.SpecialCells(xlCellTypeVisible), ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants)) If IsNumeric(rPrevCell) And IsNumeric(rCell) Then If Len(CStr(rCell)) <> 8 Then rCell.Interior.Color = vbRed If Abs(CLng(rPrevCell.Value) - CLng(rCell.Value)) = 1 Then rCell.Interior.Color = vbGreen rPrevCell.Interior.Color = vbGreen End If End If Set rPrevCell = rCell Next rCell With Application: .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlAutomatic: End With End Sub
[/vba]
Только я сделал изменение не цвета шрифта, а цвета заливки (мне так удобнее - зрение слабовато стало). Если Вам удобнее изменять цвет шрифта, от исправьте сами. Но в любом случае, если не нужно 56 цветов, то по-моему намного удобнее использовать не ColorIndex , а Color и задавать его не ничего не значащими цифрами, а понятными цифровыми константами.
И не мудрено. Кто Вас научил ТАК обращаться с массивами? И что Вы надеялись получить от CStr(alf) ? Если уж хотите что-то сравнивать с набором символов, то используйте оператор Like. Он понимает перечисления и метасимволы. Посмотрите справку. Пригодится где-нибудь. Но только не в этом случае. Тут вполне достаточно перед вычислениями проверять типы переменных любым из доступных методов [vba]
Код
If IsNumeric(rCell) Then … If TypeName(rCell) <> "String" Then … If VarType(rCell) < vbString Then …
[/vba] В общем, Ваш макрос, скорее всего заработает так:
[vba]
Код
Sub CountSymbol() Dim rCell As Range, rPrevCell As Range Set rPrevCell = ActiveWindow.RangeSelection(1) With Application: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual: End With For Each rCell In Intersect(ActiveWindow.RangeSelection.SpecialCells(xlCellTypeVisible), ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants)) If IsNumeric(rPrevCell) And IsNumeric(rCell) Then If Len(CStr(rCell)) <> 8 Then rCell.Interior.Color = vbRed If Abs(CLng(rPrevCell.Value) - CLng(rCell.Value)) = 1 Then rCell.Interior.Color = vbGreen rPrevCell.Interior.Color = vbGreen End If End If Set rPrevCell = rCell Next rCell With Application: .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlAutomatic: End With End Sub
[/vba]
Только я сделал изменение не цвета шрифта, а цвета заливки (мне так удобнее - зрение слабовато стало). Если Вам удобнее изменять цвет шрифта, от исправьте сами. Но в любом случае, если не нужно 56 цветов, то по-моему намного удобнее использовать не ColorIndex , а Color и задавать его не ничего не значащими цифрами, а понятными цифровыми константами.Alex_ST
С уважением, Алексей MS Excel 2003 - the best!!!
Сообщение отредактировал Alex_ST - Пятница, 23.05.2014, 23:09
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
