Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Excel
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 05.02.2013, 19:37   #21
strannick
Форумчанин
 
Регистрация: 21.10.2011
Сообщений: 433
По умолчанию

Блин, мужики! Пока у меня тут перебой был с интернетом, накидали материала выше крыши! Я аж подрастерялся. Свои потуги выкладывать смысла не вижу, потому как явно хуже будут, чем все вышеприведенное. Буду сам сейчас пробовать на файле!

Ага, вот не совсем то получается. Красит строки на листе Заказы, а надо красить шрифт в совпадающих ячейках лист База заказов. Причем совпадение совсем не обязательно строкой, а содержимым ячейками диапазона этой строки на листе База заказов со всем, будь он не ладен, диапазоном листа Заказы. Тут видимо названия листов сбили с толку. Лист Заказы является накопительным, куда сваливаются все обработанные заказы. На лист База заказов импортируются новые заказы, которые сравниваются с листом Заказы по указанным диапазонам ячеек и при совпадении содержимого какой-либо ячейки нового с накопительным, шрифт в ячейке красится а заказ помечается как не обработанный. Это в общем коде заложено. В принципе, все просто наоборот, но это дело техники. Почему так подробно пишу - чтоб самому не запутаться. А моет кому-то еще понадобится. Сейчас перепишу под такую постановку и проверю, а потом буду встраивать в основную процедуру. Огромнющее всем СПАСИБО за участие!

Все таки решил выложить свои потуги, чтоб понятней было:
Код:
Sub Массивы()

Dim sh As Worksheet, sh1 As Worksheet
Dim a, b, oDict1 As Object, oDict2 As Object
Dim x
    Set sh = Sheets("База заказов") 'лист с которого сравниваются ячейки диапазона и подкрашивается шрифт
    Set sh1 = Sheets("Заказы") 'лист с диапазоном с которым сравниваются ячейки
    
a = sh.Range("F2:K2").Value 'массив, ячейки которого сравниваются
b = sh1.Range("F2:K9").Value 'массив, с ячейками которого сравниваются
Set oDict1 = CreateObject("scripting.dictionary")
Set oDict2 = CreateObject("scripting.dictionary")
For Each x In a
If Len(x) Then oDict1.Item(x) = x 'добавили в словарь сравниваемые ячейки
Next
For Each x In b
If Len(x) Then oDict2.Item(x) = x 'добавили в словарь ячейки, с которыми сравниваем
Next
For Each x In oDict1.Items
If oDict2.Exists(x) Then 'вот тут прописать выделение шрифта цветом
'не могу въехать как связать совпадение х по обеим словарям с конкретной ячейкой диапазона a = sh.Range("F2:K2"), чтоб шрифт выделить цветом
Debug.Print x
End If
Next
End Sub

Последний раз редактировалось strannick; 05.02.2013 в 20:53. Причина: добавил позже
strannick вне форума Ответить с цитированием
Старый 05.02.2013, 21:11   #22
Hugo121
Старожил
 
Регистрация: 11.05.2010
Сообщений: 5,166
По умолчанию

Ну вот например так на Вашей базе:
Код:
Option Explicit

Sub Массивы()

    Dim sh As Worksheet, sh1 As Worksheet
    Dim a, b, i&, ii&, oDict2 As Object
    Dim x
    Set sh = Sheets("База заказов")    'лист с которого сравниваются ячейки диапазона и подкрашивается шрифт
    Set sh1 = Sheets("Заказы")    'лист с диапазоном с которым сравниваются ячейки

    a = sh.Range("F2:K5").Value    'массив, ячейки которого сравниваются
    b = sh1.Range("F2:K9").Value    'массив, с ячейками которого сравниваются
    Set oDict2 = CreateObject("scripting.dictionary")
    For Each x In b
        If Len(x) Then oDict2.Item(x) = 0&    'добавили в словарь ячейки, с которыми сравниваем
    Next

    For i = 1 To UBound(a)
        For ii = 1 To UBound(a, 2)
            If oDict2.Exists(a(i, ii)) Then sh.Range("F2:K2").Cells(i, ii).Interior.ColorIndex = 37
        Next
    Next

End Sub
Два словаря тут не нужны.
webmoney: E265281470651 Z422237915069 R418926282008
Hugo121 вне форума Ответить с цитированием
Старый 05.02.2013, 22:05   #23
staniiislav
Форумчанин
 
Аватар для staniiislav
 
Регистрация: 16.04.2010
Сообщений: 695
По умолчанию

а я пока хочу все же понять почему выделяется диапазон только столбца L, как заставить Intersect и SpecialCells выделять диапазон найденных значений с A:L а не только L
Вот как сейчас работает только по L:

Код:
Option Explicit
Private Declare Function GetTickCount Lib "kernel32" () As Long

Sub pokraska()
Dim a, b, i&, n&, u, sh As Worksheet, t, isect As Range
t = GetTickCount
Set sh = Sheets("Заказы")
    a = Range("F1:K" & Cells(Rows.Count, 1).End(xlUp).Row).Value
With CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(a)
        '.Item(a(i, 1)) = .Item(a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4) & "|" & a(i, 5) & "|" & a(i, 6))
         .Item(Join(Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4), a(i, 5), a(i, 6)), "|")) = Empty
    Next i

    a = sh.Range("F1:K" & sh.Cells(Rows.Count, 1).End(xlUp).Row).Value
    
    ReDim b(1 To UBound(a), 1 To 1)
    For i = 2 To UBound(a)
    u = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4) & "|" & a(i, 5) & "|" & a(i, 6)
        If .Exists(u) Then b(i, 1) = 1 ': sh.Range(sh.Cells(i, 1), sh.Cells(i, 11)).Interior.ColorIndex = 37
    Next i
End With
sh.Range("L1").Resize(UBound(b), 1).Value = b
Set isect = Intersect(sh.Range("A1:L" & UBound(b)), sh.Range("L1:L" & UBound(b)).SpecialCells(xlCellTypeConstants))
If Not isect Is Nothing Then isect.Interior.ColorIndex = 37
sh.Range("L1:L" & UBound(b)).ClearContents
Debug.Print (GetTickCount - t) / 1000
End Sub
Единственный способ стать умнее, играть с более умным противником...
staniiislav вне форума Ответить с цитированием
Старый 05.02.2013, 22:18   #24
Hugo121
Старожил
 
Регистрация: 11.05.2010
Сообщений: 5,166
По умолчанию

Ваш нелюбимый EntireRow добавьте
Код:
Set isect = Intersect(sh.Range("A1:L" & UBound(b)), sh.Range("L1:L" & UBound(b)).SpecialCells(xlCellTypeConstants).EntireRow)
webmoney: E265281470651 Z422237915069 R418926282008
Hugo121 вне форума Ответить с цитированием
Старый 05.02.2013, 22:27   #25
staniiislav
Форумчанин
 
Аватар для staniiislav
 
Регистрация: 16.04.2010
Сообщений: 695
По умолчанию

Цитата:
Сообщение от Hugo121 Посмотреть сообщение
Ваш нелюбимый EntireRow добавьте
Код:
Set isect = Intersect(sh.Range("A1:L" & UBound(b)), sh.Range("L1:L" & UBound(b)).SpecialCells(xlCellTypeConstants).EntireRow)
вот блин, все генеральное просто ))) Спасибо!
Теперь со спокойной душой пойду спать ))) а завтра с утра еще пример для strannick попытаюсь сделать!
Спасибо Hugo121 и nilem
Единственный способ стать умнее, играть с более умным противником...
staniiislav вне форума Ответить с цитированием
Старый 06.02.2013, 00:59   #26
strannick
Форумчанин
 
Регистрация: 21.10.2011
Сообщений: 433
По умолчанию

Цитата:
Сообщение от Hugo121 Посмотреть сообщение

a = sh.Range("F2:K5").Value 'массив, ячейки которого сравниваются
...............

For i = 1 To UBound(a)
For ii = 1 To UBound(a, 2)
If oDict2.Exists(a(i, ii)) Then sh.Range("F2:K2").Cells(i, ii).Interior.ColorIndex = 37
Next
Next

End Sub[/CODE]
Два словаря тут не нужны.
Не совсем так. Не a = sh.Range("F2:K5").Value, а так a = sh.Range("F2:K5").Value. Ячейки строки со 2-го по 5-й столбец.
Почему именно так? Потому что, в основном коде обработка идет построчно, переменной i уже присвоен номер обрабатываемой строки. Я тут попытался прикрутить к основному коду:

Код:
b = sh5.Range("L2:Q" & iLastRow1).Value    'массив, с ячейками которого сравниваются
    Set oDict2 = CreateObject("scripting.dictionary")
    For Each x In b
        If Len(x) Then oDict2.Item(x) = 0&    'добавили в словарь ячейки, с которыми сравниваем
    Next

For k = 12 To 17 'столбцы с L по Q
u = sh.Cells(i, k) 'цикл по одной строке с L по Q
If u <> "" Then 'потому как попадаются пустые ячейки, которые обрабатывать не надо
If oDict2.Exists(u) Then sh.Cells(i, k).Resize(j).Font.Color = -4165632: sh.Cells(i, 5).Resize(j).Value = "не обработан, Совпадение с Базой": sh.Cells(i, 5).Resize(j).Font.Color = -16776961: GoTo Metka3 'пропускаем переброску необработанного заказа в базу
End If
Next k
Наверное топорно, но все равно не срабатывает. Совпадений полно, а обработка все равно идет. Где я тут накосячил опять?
strannick вне форума Ответить с цитированием
Старый 06.02.2013, 01:58   #27
Hugo121
Старожил
 
Регистрация: 11.05.2010
Сообщений: 5,166
По умолчанию

Цитата:
Не a = sh.Range("F2:K5").Value, а так a = sh.Range("F2:K5").Value
Вроде одинаково

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

По остальному не скажу - пошёл спать
webmoney: E265281470651 Z422237915069 R418926282008
Hugo121 вне форума Ответить с цитированием
Старый 06.02.2013, 02:21   #28
strannick
Форумчанин
 
Регистрация: 21.10.2011
Сообщений: 433
По умолчанию

Цитата:
Сообщение от Hugo121 Посмотреть сообщение
Вроде одинаково

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

По остальному не скажу - пошёл спать
Да, это я уже ошибся. Вроде работает, дело в предыдущей части кода. Чего-то я там намудрил. А эта часть работает. Надо спать, а то голова уже не соображает.

Да, работает. Но в таком варианте есть одна загвоздочка. Как только находит первое совпадение, делает пометку "не обработан, совпадение с базой", закрашивает шрифт в совпавшей ячейке и выходит из цикла. Правильно, но хотелось бы, чтобы проверил все ячейки, пометил шрифт во всех совпавших и тогда перешел на Метку3. Приведу еще раз этот кусок кода, посмотрите как можно реализовать:
Код:
b = sh5.Range("L2:Q" & iLastRow1).Value    'массив, с ячейками которого сравниваются
    Set oDict2 = CreateObject("scripting.dictionary")
    For Each x In b
        If Len(x) Then oDict2.Item(x) = 0&    'добавили в словарь ячейки, с которыми сравниваем
    Next

For k = 12 To 17
u = sh.Cells(i, k).Value
If u <> "" Then
If oDict2.Exists(u) Then
sh.Cells(i, k).Resize(j).Font.Color = -4165632
sh.Cells(i, 5).Resize(j).Value = "не обработан, Совпадение с Базой"
sh.Cells(i, 5).Resize(j).Font.Color = -16776961
GoTo Metka3 'уходит на Metka3 минуя процедуры переноса в Базу, формирования счета и отправки по почте
End If
End If
Next
.............................................
Metka3:
        i = i + j

Последний раз редактировалось strannick; 06.02.2013 в 02:59. Причина: добавил позже
strannick вне форума Ответить с цитированием
Старый 06.02.2013, 11:16   #29
Hugo121
Старожил
 
Регистрация: 11.05.2010
Сообщений: 5,166
По умолчанию

Не вполне понял, зачем метка и зачем туда ходить, но не важно.
Если нужно уйти, если покрасили хоть одну, но сперва проверить все - то добавьте флаг.
Т.е.
dim flag as boolean
когда красим, то flag=true
после цикла по строке
if flag then goto metka
и не забыть вернуть где-то flag=false!
webmoney: E265281470651 Z422237915069 R418926282008
Hugo121 вне форума Ответить с цитированием
Старый 06.02.2013, 21:53   #30
nerv
Форумчанин
 
Аватар для nerv
 
Регистрация: 26.04.2010
Сообщений: 450
По умолчанию

Цитата:
Сообщение от nilem Посмотреть сообщение
один японский перец всегда вместо этого
Код:
.Item(a(i, 1)) = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4) & "|" & a(i, 5) & "|" & a(i, 6)
пишет так
Код:
.Item(a(i, 1)) = Join(Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4), a(i, 5), a(i, 6)), "|")
Стас, можете проверить? Просто для интереса. Может действительно так лучше?
читаемость в разы лучше + меньше букв. Тоже так делаю.

p.s.: ппц абвгдейка. сломай глаза и вырви мозг

UPD
Код:
.Item(a(i, 1)) = .Item(a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4) & "|" & a(i, 5) & "|" & a(i, 6))
' -->
Key = JoinU(a, i)


Function JoinU(ByRef Data() As Variant, _
               ByVal Index As Long, _
               Optional ByVal Count As Byte = 6, _
               Optional Delimiter As String = "|") As String
    Dim Arr() As Variant
    Dim Column As Byte
    
    ReDim Arr(1 To Count)
    
    For Column = 1 To Count
        Arr(Column) = Data(Index, Column)
    Next
    
    JoinU = JOIN(Arr, Delimiter)
End Function
Тишина – самый громкий звук

Последний раз редактировалось nerv; 06.02.2013 в 22:05.
nerv вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Сравнение двух диапазонов на предмет изменений strannick Microsoft Office Excel 2 29.11.2012 00:42
Сравнение двух диапазонов ячеек и выбор из них pavpin Microsoft Office Excel 2 05.09.2012 21:02
Сравнение 3-х диапазонов Severny Microsoft Office Excel 0 13.01.2012 12:23
Сравнение двух диапазонов и удаление совпадений Aniqa Microsoft Office Excel 5 20.07.2011 15:31
Сравнение двух диапазонов и удаление совпадений ПОСТРОЧНО (доработка) pringls Microsoft Office Excel 2 26.01.2011 16:54