Раскрасить часть текста в ячейке - Компьютерный форум OSzone.net

Компьютерный форум OSzone.net (http://forum.oszone.net/index.php)

- Программирование и базы данных (http://forum.oszone.net/forumdisplay.php?f=21)

- - Раскрасить часть текста в ячейке (http://forum.oszone.net/showthread.php?t=332919)

Раскрасить часть текста в ячейке

Всем привет. Собственно, надо раскрасить часть текста по условиям. Условия есть, но не знаю как описать вторую ветку. Когда не совпало в условие.
Вот код

Код:

Sub cehout()

    Application.ScreenUpdating = False

    massceh = Sheets("коды").UsedRange.Value

    arrlist = ActiveSheet.UsedRange.Value

    Ncolumn1 = Columns(1)

    Ncolumn2 = Columns(2)

    For i = 2 To UBound(arrlist)

        For j = LBound(massceh) To UBound(massceh)

            If InStr(1, Cells(i, Ncolumn2), massceh(j, 1)) > 0 Then

                If InStr(Cells(i, Ncolumn1), massceh(j, 2)) > 0 Then

                    intFoundPosition = InStr(1, Cells(i, Ncolumn1), massceh(j, 2))

                    Do While intFoundPosition > 0

                        Cells(i, Ncolumn1).Characters(intFoundPosition, Len(massceh(j, 2))).Font.color = -11489280 'зелёный

                        intFoundPosition = InStr(intFoundPosition + 1, Cells(i, Ncolumn1), massceh(j, 2), vbTextCompare)

                    Loop

                End If

            End If

        Next j

    Next i

    Application.ScreenUpdating = True

End Sub

Он закрашивает только если есть совпадение. Если нет совпадения, но есть совпадение, то надо чтоб добавлял текст в ячейку и красил её в красный.
Вот пример прилагаю.
Понимаю, что написаное вызывает удивление, но оно так и есть. Если нашлось совпадение в 2 столбце, но не нашлось совпадения в 1 столбце, надо дописать в первый столбец значение из массива находящееся во второй размерности и закрасить его красным цветом. Как закрасить в зелёный по условию, если нашлось во втором столбце и в первом, то красим. По итоговому листу видно, что хотелось бы получить.

Цитата:

Цитата blackeangel

Если нет совпадения, но есть совпадение, то надо чтоб добавлял текст в ячейку и красил её в красный. »

Школьный учитель физики утверждала, что "грамотно записанные условия задачи и чертеж - это ровно половина от решения задачи". Неоднократно убеждался, что это верное утверждение.

Цитата:

Цитата blackeangel

Ncolumn1 = Columns(1) »

Вы скопировали в переменную типа Variant значения ячеек всего столбца (то есть 1048576 штук, в основном - пустые). И пытаетесь потом использовать эту переменную в конструкции Cells(i, Ncolumn1) - у меня она закономерно выдает ошибку (т.к. Ncolumn1 должно быть целым числом, а не полупустым массивом текста). Неужели у вас это работает?

Цитата:

Цитата blackeangel

надо чтоб добавлял текст в ячейку и красил её в красный. »

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

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

Код:

Sub cehout_2()

    'Application.ScreenUpdating = False

    massceh = Sheets("коды").Cells(1, 1).CurrentRegion.Value

    ActiveSheet.Columns(2).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

    'arrlist = Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(1, 1).End(xlDown))

    

    '    Ncolumn1 = Columns(1)

    '    Ncolumn2 = Columns(2)

    For i = 1 To Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(1, 1).End(xlDown)).Rows.Count

        For j = LBound(massceh) To UBound(massceh)

            If InStr(1, Cells(i, 3), massceh(j, 1)) > 0 Then

                If InStr(Cells(i, 1), massceh(j, 2)) > 0 Then

                    intFoundPosition = InStr(1, Cells(i, 1), massceh(j, 2))

                    Do While intFoundPosition > 0

                        Cells(i, 1).Characters(intFoundPosition, Len(massceh(j, 2))).Font.Color = -11489280 'зелёный

                        intFoundPosition = InStr(intFoundPosition + 1, Cells(i, 1), massceh(j, 2), vbTextCompare)

                    Loop

                Else

                    Cells(i, 2).Value = Cells(i, 2).Value & "-" & massceh(j, 2)

                    Cells(i, 2).Font.ColorIndex = 3

                End If

            End If

        Next j

    Next i

    'Application.ScreenUpdating = True

End Sub

a_axe, верно косяк замечен. Должно было быть так

Код:

Ncolumn1 = 1

Ncolumn2 = 2

Цитата:

Проще вставить между вашими столбцами еще один пустой столбец и записывать красный текст в него в отдельную ячейку.

Надо именно в текущей ячейке.

Код:

Else

Cells(i, 2).Value = Cells(i, 2).Value & "-" & massceh(j, 2)

Cells(i, 2).Font.ColorIndex = 3

Аналогичное пробовал - забивает ячейку всем подряд из листа "коды"

Цитата:

Цитата blackeangel

забивает ячейку всем подряд из листа "коды" »

не всем подряд, а только если находит соответствие, и это происходит строго в рамках указанного вами алгоритма:

Цитата:

Цитата blackeangel

Если нашлось совпадение в 2 столбце, но не нашлось совпадения в 1 столбце, надо дописать в первый столбец значение из массива находящееся во второй размерности и закрасить его красным цветом. »

В вашем примере в первой строчке обязано появится красное значение 3100, по той причине что в кодах значение "3100" указано рядом с "с3", которое замыкает ячейку второго столбца первой строки листа "Данные". Это та самая указанная вами ситуация: нашлось совпадение в 2 столбце, но не нашлось совпадения в 1 столбце, надо дописать в первый столбец значение из массива находящееся во второй размерности и закрасить его красным цветом. В вашем листе "Итоги" это значение почему-то не вставлено, вероятно требуется еще обдумать алгоритм.

Цитата:

Цитата blackeangel

Надо именно в текущей ячейке. »

Самый простой вариант - создать дополнительный столбец, обработать значения в нем, а затем удалить весь первый столбец. Код приблизительно такой:

Скрытый текст

Код:

Sub cehout_3()

    Application.ScreenUpdating = False

    massceh = Sheets("коды").Cells(1, 1).CurrentRegion.Value

    ActiveSheet.Columns(2).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

    ActiveSheet.Cells(1, 1).CurrentRegion.AutoFill Destination:=ActiveSheet.Cells(1, 1).CurrentRegion.Resize(ActiveSheet.Cells(1, 1).CurrentRegion.Rows.Count, 2), Type:=xlFillCopy

    'arrlist = Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(1, 1).End(xlDown))

    

    '    Ncolumn1 = Columns(1)

    '    Ncolumn2 = Columns(2)

    For i = 1 To Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(1, 1).End(xlDown)).Rows.Count

        For j = LBound(massceh) To UBound(massceh)

            If InStr(1, Cells(i, 3), massceh(j, 1)) > 0 Then

                If InStr(Cells(i, 1), massceh(j, 2)) > 0 Then

                    intFoundPosition = InStr(1, Cells(i, 1), massceh(j, 2))

                    Do While intFoundPosition > 0

                        Cells(i, 2).Characters(intFoundPosition, Len(massceh(j, 2))).Font.Color = -11489280 'зелёный

                        intFoundPosition = InStr(intFoundPosition + 1, Cells(i, 2), massceh(j, 2), vbTextCompare)

                    Loop

                Else

                    Cells(i, 2).Value = Cells(i, 2).Value & "-" & massceh(j, 2)

                    Cells(i, 2).Characters(Len(Cells(i, 1).Value) + 1, Len(Cells(i, 2).Value) - Len(Cells(i, 1).Value)).Font.ColorIndex = 3

                End If

            End If

        Next j

    Next i

    ActiveSheet.Columns(1).Delete

    Application.ScreenUpdating = True

End Sub

a_axe, почти правда, придется переписать логику. Разбивая содержимое в ячейках обеих столбцов по "-" в одномерные массивы, и прокручивать их по листу "коды" и друг по другу. А то ляпов много получается. Не подскажете как удалить дубли в ячейке?