|
Компьютерный форум OSzone.net » Программирование, базы данных и автоматизация действий » Программирование и базы данных » VBA - Раскрасить часть текста в ячейке |
|
VBA - Раскрасить часть текста в ячейке
|
Старожил Сообщения: 329 |
Профиль | Отправить PM | Цитировать
Всем привет. Собственно, надо раскрасить часть текста по условиям. Условия есть, но не знаю как описать вторую ветку. Когда не совпало в условие.
Вот код 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 столбце, надо дописать в первый столбец значение из массива находящееся во второй размерности и закрасить его красным цветом. Как закрасить в зелёный по условию, если нашлось во втором столбце и в первом, то красим. По итоговому листу видно, что хотелось бы получить. |
|
Отправлено: 19:58, 01-02-2018 |
Динохромный Сообщения: 690
|
Профиль | Отправить PM | Цитировать Цитата blackeangel:
Цитата blackeangel:
Цитата 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 |
|||
Отправлено: 16:27, 02-02-2018 | #2 |
Для отключения данного рекламного блока вам необходимо зарегистрироваться или войти с учетной записью социальной сети. Если же вы забыли свой пароль на форуме, то воспользуйтесь данной ссылкой для восстановления пароля. |
Старожил Сообщения: 329
|
Профиль | Отправить PM | Цитировать a_axe, верно косяк замечен. Должно было быть так
Цитата:
Аналогичное пробовал - забивает ячейку всем подряд из листа "коды" |
|
------- Отправлено: 17:51, 02-02-2018 | #3 |
Динохромный Сообщения: 690
|
Профиль | Отправить PM | Цитировать Цитата blackeangel:
Цитата blackeangel:
Цитата 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 |
|||
Отправлено: 14:52, 03-02-2018 | #4 |
Старожил Сообщения: 329
|
Профиль | Отправить PM | Цитировать a_axe, почти правда, придется переписать логику. Разбивая содержимое в ячейках обеих столбцов по "-" в одномерные массивы, и прокручивать их по листу "коды" и друг по другу. А то ляпов много получается. Не подскажете как удалить дубли в ячейке?
|
|
------- Отправлено: 14:56, 04-02-2018 | #5 |
Участник сейчас на форуме | Участник вне форума | Автор темы | Сообщение прикреплено |
| |||||
Название темы | Автор | Информация о форуме | Ответов | Последнее сообщение | |
CMD/BAT - [решено] вырезать часть текста и скопировать его в новый файл | temphard | Скриптовые языки администрирования Windows | 20 | 09-11-2017 00:25 | |
2010 - [решено] Выделить часть текста цветом в ячейке по шаблону на всем листе | blackeangel | Microsoft Office (Word, Excel, Outlook и т.д.) | 14 | 24-05-2016 01:10 | |
Прочие БД - Нечитается часть текста в Oracle11g | slenok | Программирование и базы данных | 1 | 02-05-2010 23:16 | |
PowerShell - [решено] как раскрасить html? | Ingolder | Скриптовые языки администрирования Windows | 4 | 15-11-2009 23:24 | |
CheckBox в Ячейке DBGrid | Loki3D | Программирование и базы данных | 3 | 31-08-2005 22:54 |
|