Макрос, меняющий цвет шрифта ячейки при совпадении символов - Страница 2

Дата: Воскресенье, 13.01.2013, 11:36 | Сообщение № 21

Группа: Друзья

Ранг: Старожил

Сообщений: 1906

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

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

Excel 2003, 2010

[vba]

Код

Sub t()
       a = [b4:c28].Value
       For i = 1 To UBound(a) - 1
           e = Split(Application.Trim(a(i, 1))): j = i + 1: k = a(i, 2) * 0.3: f = False
           Do Until (j > UBound(a)) Or f
               If a(j, 2) < k Then Exit Do
               x = Split(Application.Trim(a(j, 1)))
               If UBound(x) >= UBound(e) Then
                   ff = True
                   For ie = 0 To UBound(e)
                       ff = True
                       For ix = 0 To UBound(x)
                           If e(ie) = x(ix) Then ff = False: Exit For
                       Next
                       If ff Then Exit For
                   Next
                   If Not ff Then Cells(i + 3, 2).Font.ColorIndex = 15: f = True
               End If
               j = j + 1
           Loop
       Next
End Sub

[/vba]
пс. обратите внимание - первая строка не закрасилась, ибо не попадает в ваши пресловутые 30%

помощь по Excel и VBA
ikki@fxmail.ru, icq 592842413, skype alex.ikki

Сообщение отредактировал ikki - Воскресенье, 13.01.2013, 12:31

Дата: Воскресенье, 13.01.2013, 12:30 | Сообщение № 22

Группа: Друзья

Ранг: Старожил

Сообщений: 1906

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

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

Excel 2003, 2010

другой вариант (в общем-то, не короче и вряд ли быстрее, просто разбираться и править удобнее)

[vba]

Код

Sub tt()
      Set d = CreateObject("scripting.dictionary")
      a = [b4:c28].Value
      For i = 1 To UBound(a) - 1
          e = Split(Application.Trim(a(i, 1)))
          For ie = 0 To UBound(e): d.Item(e(ie)) = 0: Next
          j = i + 1: k = a(i, 2) * 0.3: f = False
          Do Until (j > UBound(a)) Or f
              If a(j, 2) < k Then Exit Do
              x = Split(Application.Trim(a(j, 1)))
              If UBound(x) >= UBound(e) Then
                  ff = True
                  For ix = 0 To UBound(x)
                      If Not d.exists(x(ix)) Then ff = False: Exit For
                  Next
                  If ff Then Cells(i + 3, 2).Font.ColorIndex = 15: f = True
              End If
              j = j + 1
          Loop
          d.RemoveAll
      Next
End Sub

[/vba]

пс. есть нюанс - и в том, и в другом коде. для случая наличия повторяющихся слов в строках может работать неверно. но в примере таких случаев нет smile

помощь по Excel и VBA
ikki@fxmail.ru, icq 592842413, skype alex.ikki

Сообщение отредактировал ikki - Воскресенье, 13.01.2013, 12:35

Дата: Воскресенье, 13.01.2013, 14:54 | Сообщение № 23

Группа: Гости

Ikki, спасибо за помощь.

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

Будьте добры, посмотрите файл с макросом. hayabusa-club.ru/macros.xls (это книга с поддержкой макросов, у файла поменяно расширение, т.к. xlsm не скачивается с сервера.)

Дата: Воскресенье, 13.01.2013, 14:56 | Сообщение № 24

Группа: Гости

Второй макрос запустить не получилось. Ошибок не пишет, но и ничего не происходит.

Дата: Воскресенье, 13.01.2013, 15:28 | Сообщение № 25

Группа: Друзья

Ранг: Старожил

Сообщений: 1906

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

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

Excel 2003, 2010

регистрируйтесь на форуме, прикрепляйте файл - будет разговор.

помощь по Excel и VBA
ikki@fxmail.ru, icq 592842413, skype alex.ikki

Дата: Воскресенье, 13.01.2013, 16:21 | Сообщение № 26

Группа: Пользователи

Ранг: Прохожий

Сообщений: 2

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

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

Прикрепил

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

Дата: Воскресенье, 13.01.2013, 20:00 | Сообщение № 27

Группа: Друзья

Ранг: Старожил

Сообщений: 1906

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

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

Excel 2003, 2010

посмотрел.
все претензии можете переадресовать себе обратно. biggrin

диапазон сдвинули, а макрос поменяли лишь частично.

ищем строку
[vba]

Код

If Not ff Then Cells(i + 3, 2).Font.ColorIndex = 15: f = True

[/vba]
и меняем так:
[vba]

Код

If Not ff Then Cells(i + 1, 2).Font.ColorIndex = 15: f = True

[/vba]

помощь по Excel и VBA
ikki@fxmail.ru, icq 592842413, skype alex.ikki

Дата: Воскресенье, 13.01.2013, 23:03 | Сообщение № 28

Группа: Пользователи

Ранг: Прохожий

Сообщений: 2

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

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

Большое спасибо!

Если я хочу расширить диапазон строк листа до 1000, эта строка кода макроса останется в таком же виде?

Код

If Not ff Then Cells(i + 1, 2).Font.ColorIndex = 15: f = True

В этом я чайник и в инструкции ответ не нашел, но пожалуйста поделитесь чем отличается

Код

Then Cells(i + 3, 2)

от

Код

Then Cells(i + 1, 2)

Вам + в репу)).

С удовольствием вас отблагодарю. Могу ответить на юридический вопрос или нарисовать картинку в ФШ.

Сообщение отредактировал Викт0р - Воскресенье, 13.01.2013, 23:06

Дата: Воскресенье, 13.01.2013, 23:09 | Сообщение № 29

Группа: Друзья

Ранг: Старожил

Сообщений: 1906

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

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

Excel 2003, 2010

ну, в общем можно немножко переписать макрос - и тогда с этим заморачиваться не придётся.
а пока - число, которое прибавляется в этой строке к i - это, по сути, число строк, на которое сдвинуто начало диапазона от первой строки листа.
т.е. № первой строки диапазона минус единица.

в вашем первом примере данные начинались с 4-й строки - поэтому прибавляли 3.
во втором - со второй, поэтому прибавляем 1.

помощь по Excel и VBA
ikki@fxmail.ru, icq 592842413, skype alex.ikki